{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.DecorationEx.LayoutModifier
-- Description :  Layout modifier which adds decorations to windows.
-- 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
--
-- Layout modifier, which is responsible for creation of decoration rectangles
-- (windows), updating and removing them when needed. It is parameterized by
-- @DecorationGeometry@, which says where decorations should be placed, and by
-- @DecorationEngine@, which says how decorations should look.
-----------------------------------------------------------------------------

module XMonad.Layout.DecorationEx.LayoutModifier (
    -- * Usage
    --
    -- $usage
    decorationEx,
    DecorationEx
  ) where

import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as W
import XMonad.Layout.LayoutModifier
import XMonad.Layout.WindowArranger (diff, listFromList)
import XMonad.Util.Invisible
import XMonad.Util.XUtils hiding (paintTextAndIcons)

import XMonad.Layout.DecorationEx.Common
import XMonad.Layout.DecorationEx.Engine
import XMonad.Layout.DecorationEx.Geometry

-- $usage
--
-- This module exports @decorationEx@ function, which is a generic function for
-- adding decorations to your layouts. It can be used to use different
-- decoration geometries and engines in any combination.
-- For most used combinations, there are convenience functions in
-- "XMonad.Layout.DecorationEx.TextEngine", "XMonad.Layout.DecorationEx.TabbedGeometry",
-- and "XMonad.Layout.DecorationEx.DwmGeometry".
--
-- You can use this module with the following in your
-- @xmonad.hs@:
--
-- > import XMonad.Layout.DecorationEx.LayoutModifier
-- Then edit your @layoutHook@ by adding the DwmStyle decoration to
-- your layout:
--
-- > myL = decorationEx shrinkText myTheme myEngine myGeometry (layoutHook def)
-- >         where
-- >           myGeometry = DefaultGeometry -- or another geometry type
-- >           myEngine = TextDecoration    -- or another decoration engine
-- >           myTheme = GenericTheme {...} -- theme type should correspond to selected engine type
-- >
-- > main = xmonad def { layoutHook = myL }
--
-- For more detailed instructions on editing the layoutHook see:
--
-- "XMonad.Doc.Extending#Editing_the_layout_hook"


-- | The 'DecorationEx' 'LayoutModifier'. This data type is an instance
-- of the 'LayoutModifier' class. This data type will be passed,
-- together with a layout, to the 'ModifiedLayout' type constructor
-- to modify the layout by adding decorations according to a
-- 'DecorationEngine'.
data DecorationEx engine widget geom shrinker a =
    DecorationEx (Invisible Maybe (DecorationLayoutState engine)) shrinker (Theme engine widget) (engine widget a) (geom a)

deriving instance (Show (Theme engine widget), Show shrinker, Show (engine widget a), Show (geom a)) => Show (DecorationEx engine widget geom shrinker a)
deriving instance (Read (Theme engine widget), Read shrinker, Read (engine widget a), Read (geom a)) => Read (DecorationEx engine widget geom shrinker a)

-- | The long 'LayoutModifier' instance for the 'DecorationEx' type.
--
-- In 'redoLayout' we check the state: if there is no state we
-- initialize it.
--
-- The state is @diff@ed against the list of windows produced by the
-- underlying layout: removed windows get deleted and new ones
-- decorated by 'createDecos', which will call 'decorate' to decide if
-- a window must be given a 'Rectangle', in which case a decoration
-- window will be created.
--
-- After that we resync the updated state with the windows' list and
-- then we process the resynced stated (as we do with a new state).
--
-- First we map the decoration windows, we update each decoration to
-- reflect any decorated window's change, and we insert, in the list
-- of windows and rectangles returned by the underlying layout, the
-- decoration for each window. This way xmonad will restack the
-- decorations and their windows accordingly. At the end we remove
-- invisible\/stacked windows.
--
-- Message handling is quite simple: when needed we release the state
-- component of the 'DecorationEx' 'LayoutModifier'. Otherwise we call
-- 'handleEvent', which will call the appropriate 'DecorationEngine'
-- methods to perform its tasks.
instance (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker) => LayoutModifier (DecorationEx engine widget geom shrinker) Window where
    redoLayout :: DecorationEx engine widget geom shrinker Window
-> Rectangle
-> Maybe (Stack Window)
-> [(Window, Rectangle)]
-> X ([(Window, Rectangle)],
      Maybe (DecorationEx engine widget geom shrinker Window))
redoLayout (DecorationEx (I (Just DecorationLayoutState engine
decoState)) shrinker
shrinker Theme engine widget
theme engine widget Window
engine geom Window
geom) Rectangle
_ Maybe (Stack Window)
Nothing [(Window, Rectangle)]
_ = do
        forall (engine :: * -> * -> *) widget.
DecorationEngine engine widget Window =>
engine widget Window -> DecorationLayoutState engine -> X ()
releaseResources engine widget Window
engine DecorationLayoutState engine
decoState
        forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker a.
Invisible Maybe (DecorationLayoutState engine)
-> shrinker
-> Theme engine widget
-> engine widget a
-> geom a
-> DecorationEx engine widget geom shrinker a
DecorationEx (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing) shrinker
shrinker Theme engine widget
theme engine widget Window
engine geom Window
geom)
    redoLayout DecorationEx engine widget geom shrinker Window
_ Rectangle
_ Maybe (Stack Window)
Nothing [(Window, Rectangle)]
_  = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Maybe a
Nothing)

    redoLayout (DecorationEx Invisible Maybe (DecorationLayoutState engine)
invState shrinker
shrinker Theme engine widget
theme engine widget Window
engine geom Window
geom) Rectangle
screenRect (Just Stack Window
stack) [(Window, Rectangle)]
srcPairs
        | I Maybe (DecorationLayoutState engine)
Nothing  <- Invisible Maybe (DecorationLayoutState engine)
invState = forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker.
(DecorationEngine engine widget Window,
 DecorationGeometry geom Window, Shrinker shrinker) =>
Theme engine widget
-> engine widget Window
-> geom Window
-> shrinker
-> Rectangle
-> Stack Window
-> [(Window, Rectangle)]
-> X (DecorationLayoutState engine)
initState Theme engine widget
theme engine widget Window
engine geom Window
geom shrinker
shrinker Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
srcPairs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DecorationLayoutState engine
-> X ([(Window, Rectangle)],
      Maybe (DecorationEx engine widget geom shrinker Window))
processState
        | I (Just DecorationLayoutState engine
s) <- Invisible Maybe (DecorationLayoutState engine)
invState = do
            let decorations :: [WindowDecoration]
decorations  = forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations DecorationLayoutState engine
s
                ([Window]
d,[Window]
a) = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. Eq a => ([a], [a]) -> ([a], [a])
diff ([WindowDecoration] -> [Window]
getOrigWindows [WindowDecoration]
decorations) [Window]
srcWindows
                toDel :: [WindowDecoration]
toDel = [Window] -> [WindowDecoration] -> [WindowDecoration]
todel [Window]
d [WindowDecoration]
decorations
                toAdd :: [(Window, Rectangle)]
toAdd = [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
toadd [Window]
a [(Window, Rectangle)]
srcPairs
            [WindowDecoration] -> X ()
deleteDecos [WindowDecoration]
toDel
            let decosToBeAdded :: [WindowDecoration]
decosToBeAdded = [Window
-> Rectangle
-> Maybe Window
-> Maybe Rectangle
-> [WidgetPlace]
-> WindowDecoration
WindowDecoration Window
win Rectangle
rect forall a. Maybe a
Nothing forall a. Maybe a
Nothing [] | (Window
win, Rectangle
rect) <- [(Window, Rectangle)]
toAdd]
            [WindowDecoration]
newDecorations <- DecorationEngineState engine
-> [WindowDecoration]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
resync (forall (engine :: * -> * -> *).
DecorationLayoutState engine -> DecorationEngineState engine
dsStyleState DecorationLayoutState engine
s) ([WindowDecoration]
decosToBeAdded forall a. [a] -> [a] -> [a]
++ [Window] -> [WindowDecoration] -> [WindowDecoration]
del_dwrs [Window]
d [WindowDecoration]
decorations) [(Window, Rectangle)]
srcPairs
            DecorationLayoutState engine
-> X ([(Window, Rectangle)],
      Maybe (DecorationEx engine widget geom shrinker Window))
processState (DecorationLayoutState engine
s {dsDecorations :: [WindowDecoration]
dsDecorations = [WindowDecoration]
newDecorations})

        where
          srcWindows :: [Window]
srcWindows = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Window, Rectangle)]
srcPairs

          getOrigWindows :: [WindowDecoration] -> [Window]
          getOrigWindows :: [WindowDecoration] -> [Window]
getOrigWindows = forall a b. (a -> b) -> [a] -> [b]
map WindowDecoration -> Window
wdOrigWindow

          del_dwrs :: [Window] -> [WindowDecoration] -> [WindowDecoration]
          del_dwrs :: [Window] -> [WindowDecoration] -> [WindowDecoration]
del_dwrs = forall b c a. (b -> c) -> (c -> [a] -> Bool) -> [a] -> [b] -> [b]
listFromList WindowDecoration -> Window
wdOrigWindow forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem

          findDecoWindow :: Int -> [WindowDecoration] -> Maybe Window
          findDecoWindow :: Int -> [WindowDecoration] -> Maybe Window
findDecoWindow Int
i [WindowDecoration]
d = WindowDecoration -> Maybe Window
wdDecoWindow forall a b. (a -> b) -> a -> b
$ [WindowDecoration]
d forall a. [a] -> Int -> a
!! Int
i

          todel :: [Window] -> [WindowDecoration] -> [WindowDecoration]
          todel :: [Window] -> [WindowDecoration] -> [WindowDecoration]
todel [Window]
d = forall a. (a -> Bool) -> [a] -> [a]
filter (\WindowDecoration
dd -> WindowDecoration -> Window
wdOrigWindow WindowDecoration
dd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
d)

          toadd :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
          toadd :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
toadd [Window]
a = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Window, Rectangle)
p -> forall a b. (a, b) -> a
fst (Window, Rectangle)
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
a)

          createDecoWindowIfNeeded :: Maybe Window -> Maybe Rectangle -> X (Maybe Window)
          createDecoWindowIfNeeded :: Maybe Window -> Maybe Rectangle -> X (Maybe Window)
createDecoWindowIfNeeded Maybe Window
mbDecoWindow Maybe Rectangle
mbDecoRect =
            case (Maybe Window
mbDecoWindow, Maybe Rectangle
mbDecoRect) of
              (Maybe Window
Nothing, Just Rectangle
decoRect) -> do
                Window
decoWindow <- forall (engine :: * -> * -> *) widget.
DecorationEngine engine widget Window =>
engine widget Window
-> Theme engine widget -> Rectangle -> X Window
createDecoWindow engine widget Window
engine Theme engine widget
theme Rectangle
decoRect
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Window
decoWindow
              (Maybe Window, Maybe Rectangle)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Window
mbDecoWindow

          resync :: DecorationEngineState engine -> [WindowDecoration] -> [(Window,Rectangle)] -> X [WindowDecoration]
          resync :: DecorationEngineState engine
-> [WindowDecoration]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
resync DecorationEngineState engine
_ [WindowDecoration]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
          resync DecorationEngineState engine
decoState [WindowDecoration]
dd ((Window
window,Rectangle
rect):[(Window, Rectangle)]
xs) =
            case  Window
window forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [WindowDecoration] -> [Window]
getOrigWindows [WindowDecoration]
dd of
              Just Int
i  -> do
                Maybe Rectangle
mbDecoRect <- forall (geom :: * -> *) a.
DecorationGeometry geom a =>
geom a
-> Rectangle
-> Stack a
-> [(a, Rectangle)]
-> (a, Rectangle)
-> X (Maybe Rectangle)
decorateWindow geom Window
geom Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
srcPairs (Window
window,Rectangle
rect)
                WidgetLayout WidgetPlace
widgetPlaces <- case Maybe Rectangle
mbDecoRect of
                                  Maybe Rectangle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a] -> [a] -> WidgetLayout a
WidgetLayout [] [] []
                                  Just Rectangle
decoRect -> forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> Theme engine widget
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Window
-> WidgetLayout widget
-> X (WidgetLayout WidgetPlace)
placeWidgets engine widget Window
engine Theme engine widget
theme shrinker
shrinker DecorationEngineState engine
decoState Rectangle
decoRect Window
window (forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme)
                Maybe Window
mbDecoWindow  <- Maybe Window -> Maybe Rectangle -> X (Maybe Window)
createDecoWindowIfNeeded (Int -> [WindowDecoration] -> Maybe Window
findDecoWindow Int
i [WindowDecoration]
dd) Maybe Rectangle
mbDecoRect
                let newDd :: WindowDecoration
newDd = Window
-> Rectangle
-> Maybe Window
-> Maybe Rectangle
-> [WidgetPlace]
-> WindowDecoration
WindowDecoration Window
window Rectangle
rect Maybe Window
mbDecoWindow Maybe Rectangle
mbDecoRect (forall widget. WidgetLayout widget -> [widget]
widgetLayout WidgetLayout WidgetPlace
widgetPlaces)
                [WindowDecoration]
restDd <- DecorationEngineState engine
-> [WindowDecoration]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
resync DecorationEngineState engine
decoState [WindowDecoration]
dd [(Window, Rectangle)]
xs
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WindowDecoration
newDd forall a. a -> [a] -> [a]
: [WindowDecoration]
restDd
              Maybe Int
Nothing -> DecorationEngineState engine
-> [WindowDecoration]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
resync DecorationEngineState engine
decoState [WindowDecoration]
dd [(Window, Rectangle)]
xs

          -- We drop any windows that are *precisely* stacked underneath
          -- another window: these must be intended to be tabbed!
          removeTabbed :: [Rectangle] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
          removeTabbed :: [Rectangle] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
removeTabbed [Rectangle]
_ [] = []
          removeTabbed [Rectangle]
rs ((Window
w,Rectangle
r):[(Window, Rectangle)]
xs)
              | Rectangle
r forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rectangle]
rs = [Rectangle] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
removeTabbed [Rectangle]
rs [(Window, Rectangle)]
xs
              | Bool
otherwise   = (Window
w,Rectangle
r) forall a. a -> [a] -> [a]
: [Rectangle] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
removeTabbed (Rectangle
rforall a. a -> [a] -> [a]
:[Rectangle]
rs) [(Window, Rectangle)]
xs

          insertDwr :: WindowDecoration -> [(Window, Rectangle)] -> [(Window, Rectangle)]
          insertDwr :: WindowDecoration -> [(Window, Rectangle)] -> [(Window, Rectangle)]
insertDwr WindowDecoration
dd [(Window, Rectangle)]
wrs =
            case (WindowDecoration -> Maybe Window
wdDecoWindow WindowDecoration
dd, WindowDecoration -> Maybe Rectangle
wdDecoRect WindowDecoration
dd) of
              (Just Window
decoWindow, Just Rectangle
decoRect) -> (Window
decoWindow, Rectangle
decoRect) forall a. a -> [a] -> [a]
: (WindowDecoration -> Window
wdOrigWindow WindowDecoration
dd, forall (geom :: * -> *) a.
DecorationGeometry geom a =>
geom a -> Rectangle -> Rectangle -> Rectangle
shrinkWindow geom Window
geom Rectangle
decoRect (WindowDecoration -> Rectangle
wdOrigWinRect WindowDecoration
dd)) forall a. a -> [a] -> [a]
: [(Window, Rectangle)]
wrs
              (Maybe Window, Maybe Rectangle)
_ -> (WindowDecoration -> Window
wdOrigWindow WindowDecoration
dd, WindowDecoration -> Rectangle
wdOrigWinRect WindowDecoration
dd) forall a. a -> [a] -> [a]
: [(Window, Rectangle)]
wrs

          dwrs_to_wrs :: [WindowDecoration] -> [(Window, Rectangle)]
          dwrs_to_wrs :: [WindowDecoration] -> [(Window, Rectangle)]
dwrs_to_wrs = [Rectangle] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
removeTabbed [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr WindowDecoration -> [(Window, Rectangle)] -> [(Window, Rectangle)]
insertDwr []

          processState :: DecorationLayoutState engine -> X ([(Window, Rectangle)], Maybe (DecorationEx engine widget geom shrinker Window))
          processState :: DecorationLayoutState engine
-> X ([(Window, Rectangle)],
      Maybe (DecorationEx engine widget geom shrinker Window))
processState DecorationLayoutState engine
st = do
            let decorations :: [WindowDecoration]
decorations = forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations DecorationLayoutState engine
st
            [WindowDecoration] -> X ()
showDecos [WindowDecoration]
decorations
            forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationEngineState engine
-> [WindowDecoration]
-> X ()
updateDecos engine widget Window
engine shrinker
shrinker Theme engine widget
theme (forall (engine :: * -> * -> *).
DecorationLayoutState engine -> DecorationEngineState engine
dsStyleState DecorationLayoutState engine
st) [WindowDecoration]
decorations
            forall (m :: * -> *) a. Monad m => a -> m a
return ([WindowDecoration] -> [(Window, Rectangle)]
dwrs_to_wrs [WindowDecoration]
decorations, forall a. a -> Maybe a
Just (forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker a.
Invisible Maybe (DecorationLayoutState engine)
-> shrinker
-> Theme engine widget
-> engine widget a
-> geom a
-> DecorationEx engine widget geom shrinker a
DecorationEx (forall (m :: * -> *) a. m a -> Invisible m a
I (forall a. a -> Maybe a
Just (DecorationLayoutState engine
st {dsDecorations :: [WindowDecoration]
dsDecorations = [WindowDecoration]
decorations}))) shrinker
shrinker Theme engine widget
theme engine widget Window
engine geom Window
geom))

    handleMess :: DecorationEx engine widget geom shrinker Window
-> SomeMessage
-> X (Maybe (DecorationEx engine widget geom shrinker Window))
handleMess (DecorationEx (I (Just DecorationLayoutState engine
st)) shrinker
shrinker Theme engine widget
theme engine widget Window
engine geom Window
geom) SomeMessage
m
        | Just LayoutMessages
Hide <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do
            [WindowDecoration] -> X ()
hideDecos forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations DecorationLayoutState engine
st
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
--         | Just (SetTheme nt) <- fromMessage m = do
--             releaseResources engine st
--             let t' = themeEx nt
--             return $ Just $ DecorationEx (I Nothing) shrinker t' engine
        | Just LayoutMessages
ReleaseResources <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do
            forall (engine :: * -> * -> *) widget.
DecorationEngine engine widget Window =>
engine widget Window -> DecorationLayoutState engine -> X ()
releaseResources engine widget Window
engine DecorationLayoutState engine
st
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker a.
Invisible Maybe (DecorationLayoutState engine)
-> shrinker
-> Theme engine widget
-> engine widget a
-> geom a
-> DecorationEx engine widget geom shrinker a
DecorationEx (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing) shrinker
shrinker Theme engine widget
theme  engine widget Window
engine geom Window
geom
        | Just Event
e <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do
            forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> Theme engine widget
-> DecorationLayoutState engine
-> shrinker
-> Event
-> X ()
decorationEventHookEx engine widget Window
engine Theme engine widget
theme DecorationLayoutState engine
st shrinker
shrinker Event
e
            forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationLayoutState engine
-> Event
-> X ()
handleEvent engine widget Window
engine shrinker
shrinker Theme engine widget
theme DecorationLayoutState engine
st Event
e
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    handleMess DecorationEx engine widget geom shrinker Window
_ SomeMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    modifierDescription :: DecorationEx engine widget geom shrinker Window -> String
modifierDescription (DecorationEx Invisible Maybe (DecorationLayoutState engine)
_ shrinker
_ Theme engine widget
_ engine widget Window
engine geom Window
geom) = forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a -> String
describeEngine engine widget Window
engine forall a. [a] -> [a] -> [a]
++ forall (geom :: * -> *) a.
DecorationGeometry geom a =>
geom a -> String
describeGeometry geom Window
geom

-- | By default 'DecorationEx' handles 'PropertyEvent' and 'ExposeEvent'
-- only.
handleEvent :: (Shrinker shrinker, DecorationEngine engine widget Window) => engine widget Window -> shrinker -> Theme engine widget -> DecorationLayoutState engine -> Event -> X ()
handleEvent :: forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationLayoutState engine
-> Event
-> X ()
handleEvent engine widget Window
engine shrinker
shrinker Theme engine widget
theme (DecorationLayoutState {[WindowDecoration]
DecorationEngineState engine
dsDecorations :: [WindowDecoration]
dsStyleState :: DecorationEngineState engine
dsStyleState :: forall (engine :: * -> * -> *).
DecorationLayoutState engine -> DecorationEngineState engine
dsDecorations :: forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
..}) Event
e
    | PropertyEvent {ev_window :: Event -> Window
ev_window = Window
w, ev_atom :: Event -> Window
ev_atom = Window
atom} <- Event
e
    , Just Int
i <- Window
w forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` forall a b. (a -> b) -> [a] -> [b]
map WindowDecoration -> Window
wdOrigWindow [WindowDecoration]
dsDecorations = do
        [Window]
supportedAtoms <- forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a -> X [Window]
propsToRepaintDecoration engine widget Window
engine
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
atom forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
supportedAtoms) forall a b. (a -> b) -> a -> b
$ do
          -- io $ putStrLn $ "property event on " ++ show w -- ++ ": " ++ fromMaybe "<?>" atomName
          forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationEngineState engine
-> WindowDecoration
-> Bool
-> X ()
updateDeco engine widget Window
engine shrinker
shrinker Theme engine widget
theme DecorationEngineState engine
dsStyleState ([WindowDecoration]
dsDecorations forall a. [a] -> Int -> a
!! Int
i) Bool
False
    | ExposeEvent   {ev_window :: Event -> Window
ev_window = Window
w} <- Event
e
    , Just Int
i <- Window
w forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe WindowDecoration -> Maybe Window
wdDecoWindow [WindowDecoration]
dsDecorations = do
        -- io $ putStrLn $ "expose event on " ++ show w
        forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationEngineState engine
-> WindowDecoration
-> Bool
-> X ()
updateDeco engine widget Window
engine shrinker
shrinker Theme engine widget
theme DecorationEngineState engine
dsStyleState ([WindowDecoration]
dsDecorations forall a. [a] -> Int -> a
!! Int
i) Bool
True
handleEvent engine widget Window
_ shrinker
_ Theme engine widget
_ DecorationLayoutState engine
_ Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Initialize the 'DecorationState' by initializing the font
-- structure and by creating the needed decorations.
initState :: (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker)
          => Theme engine widget
          -> engine widget Window
          -> geom Window
          -> shrinker
          -> Rectangle
          -> W.Stack Window
          -> [(Window,Rectangle)] -> X (DecorationLayoutState engine)
initState :: forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker.
(DecorationEngine engine widget Window,
 DecorationGeometry geom Window, Shrinker shrinker) =>
Theme engine widget
-> engine widget Window
-> geom Window
-> shrinker
-> Rectangle
-> Stack Window
-> [(Window, Rectangle)]
-> X (DecorationLayoutState engine)
initState Theme engine widget
theme engine widget Window
engine geom Window
geom shrinker
shrinker Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
wrs = do
  DecorationEngineState engine
styleState <- forall (engine :: * -> * -> *) widget a (geom :: * -> *).
DecorationEngine engine widget a =>
engine widget a
-> geom a
-> Theme engine widget
-> X (DecorationEngineState engine)
initializeState engine widget Window
engine geom Window
geom Theme engine widget
theme
  [WindowDecoration]
decorations <- forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker.
(DecorationEngine engine widget Window,
 DecorationGeometry geom Window, Shrinker shrinker) =>
Theme engine widget
-> engine widget Window
-> geom Window
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Stack Window
-> [(Window, Rectangle)]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
createDecos Theme engine widget
theme engine widget Window
engine geom Window
geom shrinker
shrinker DecorationEngineState engine
styleState Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
wrs [(Window, Rectangle)]
wrs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *).
DecorationEngineState engine
-> [WindowDecoration] -> DecorationLayoutState engine
DecorationLayoutState DecorationEngineState engine
styleState [WindowDecoration]
decorations

-- | Delete windows stored in the state and release the font structure.
releaseResources :: DecorationEngine engine widget Window => engine widget Window -> DecorationLayoutState engine -> X ()
releaseResources :: forall (engine :: * -> * -> *) widget.
DecorationEngine engine widget Window =>
engine widget Window -> DecorationLayoutState engine -> X ()
releaseResources engine widget Window
engine DecorationLayoutState engine
st = do
  [WindowDecoration] -> X ()
deleteDecos (forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations DecorationLayoutState engine
st)
  forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a -> DecorationEngineState engine -> X ()
releaseStateResources engine widget Window
engine (forall (engine :: * -> * -> *).
DecorationLayoutState engine -> DecorationEngineState engine
dsStyleState DecorationLayoutState engine
st)

-- | Create the decoration windows of a list of windows and their
-- rectangles, by calling the 'decorate' method of the
-- 'DecorationStyle' received.
createDecos :: (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker)
            => Theme engine widget
            -> engine widget Window
            -> geom Window
            -> shrinker
            -> DecorationEngineState engine
            -> Rectangle
            -> W.Stack Window
            -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [WindowDecoration]
createDecos :: forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker.
(DecorationEngine engine widget Window,
 DecorationGeometry geom Window, Shrinker shrinker) =>
Theme engine widget
-> engine widget Window
-> geom Window
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Stack Window
-> [(Window, Rectangle)]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
createDecos Theme engine widget
theme engine widget Window
engine geom Window
geom shrinker
shrinker DecorationEngineState engine
decoState Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
wrs ((Window
w,Rectangle
r):[(Window, Rectangle)]
xs) = do
  Maybe Rectangle
mbDecoRect <- forall (geom :: * -> *) a.
DecorationGeometry geom a =>
geom a
-> Rectangle
-> Stack a
-> [(a, Rectangle)]
-> (a, Rectangle)
-> X (Maybe Rectangle)
decorateWindow geom Window
geom Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
wrs (Window
w,Rectangle
r)
  case Maybe Rectangle
mbDecoRect of
    Just Rectangle
decoRect -> do
      Window
decoWindow <- forall (engine :: * -> * -> *) widget.
DecorationEngine engine widget Window =>
engine widget Window
-> Theme engine widget -> Rectangle -> X Window
createDecoWindow engine widget Window
engine Theme engine widget
theme Rectangle
decoRect
      WidgetLayout WidgetPlace
widgetPlaces <- forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> Theme engine widget
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Window
-> WidgetLayout widget
-> X (WidgetLayout WidgetPlace)
placeWidgets engine widget Window
engine Theme engine widget
theme shrinker
shrinker DecorationEngineState engine
decoState Rectangle
decoRect Window
w (forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme)
      [WindowDecoration]
restDd <- forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker.
(DecorationEngine engine widget Window,
 DecorationGeometry geom Window, Shrinker shrinker) =>
Theme engine widget
-> engine widget Window
-> geom Window
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Stack Window
-> [(Window, Rectangle)]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
createDecos Theme engine widget
theme engine widget Window
engine geom Window
geom shrinker
shrinker DecorationEngineState engine
decoState Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
wrs [(Window, Rectangle)]
xs
      let newDd :: WindowDecoration
newDd = Window
-> Rectangle
-> Maybe Window
-> Maybe Rectangle
-> [WidgetPlace]
-> WindowDecoration
WindowDecoration Window
w Rectangle
r (forall a. a -> Maybe a
Just Window
decoWindow) (forall a. a -> Maybe a
Just Rectangle
decoRect) forall a b. (a -> b) -> a -> b
$ forall widget. WidgetLayout widget -> [widget]
widgetLayout WidgetLayout WidgetPlace
widgetPlaces
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WindowDecoration
newDd forall a. a -> [a] -> [a]
: [WindowDecoration]
restDd
    Maybe Rectangle
Nothing -> do
      [WindowDecoration]
restDd <- forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker.
(DecorationEngine engine widget Window,
 DecorationGeometry geom Window, Shrinker shrinker) =>
Theme engine widget
-> engine widget Window
-> geom Window
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Stack Window
-> [(Window, Rectangle)]
-> [(Window, Rectangle)]
-> X [WindowDecoration]
createDecos Theme engine widget
theme engine widget Window
engine geom Window
geom shrinker
shrinker DecorationEngineState engine
decoState Rectangle
screenRect Stack Window
stack [(Window, Rectangle)]
wrs [(Window, Rectangle)]
xs
      let newDd :: WindowDecoration
newDd = Window
-> Rectangle
-> Maybe Window
-> Maybe Rectangle
-> [WidgetPlace]
-> WindowDecoration
WindowDecoration Window
w Rectangle
r forall a. Maybe a
Nothing forall a. Maybe a
Nothing []
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WindowDecoration
newDd forall a. a -> [a] -> [a]
: [WindowDecoration]
restDd
createDecos Theme engine widget
_ engine widget Window
_ geom Window
_ shrinker
_ DecorationEngineState engine
_ Rectangle
_ Stack Window
_ [(Window, Rectangle)]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []

createDecoWindow :: (DecorationEngine engine widget Window) => engine widget Window -> Theme engine widget -> Rectangle -> X Window
createDecoWindow :: forall (engine :: * -> * -> *) widget.
DecorationEngine engine widget Window =>
engine widget Window
-> Theme engine widget -> Rectangle -> X Window
createDecoWindow engine widget Window
engine Theme engine widget
theme Rectangle
rect = do
  let mask :: Maybe Window
mask = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a -> Window
decorationXEventMask engine widget Window
engine
  Window
w <- Rectangle -> Maybe Window -> String -> Bool -> X Window
createNewWindow Rectangle
rect Maybe Window
mask (forall theme. ThemeAttributes theme => theme -> String
defaultBgColor Theme engine widget
theme) Bool
True
  Display
d <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> ClassHint -> IO ()
setClassHint Display
d Window
w (String -> String -> ClassHint
ClassHint String
"xmonad-decoration" String
"xmonad")
  forall (m :: * -> *) a. Monad m => a -> m a
return Window
w

showDecos :: [WindowDecoration] -> X ()
showDecos :: [WindowDecoration] -> X ()
showDecos [WindowDecoration]
dd =
  [Window] -> X ()
showWindows forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe WindowDecoration -> Maybe Window
wdDecoWindow forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowDecoration -> Maybe Rectangle
wdDecoRect) [WindowDecoration]
dd

hideDecos :: [WindowDecoration] -> X ()
hideDecos :: [WindowDecoration] -> X ()
hideDecos = [Window] -> X ()
hideWindows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe WindowDecoration -> Maybe Window
wdDecoWindow

deleteDecos :: [WindowDecoration] -> X ()
deleteDecos :: [WindowDecoration] -> X ()
deleteDecos = [Window] -> X ()
deleteWindows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe WindowDecoration -> Maybe Window
wdDecoWindow

updateDecos :: (Shrinker shrinker, DecorationEngine engine widget Window)
            => engine widget Window -> shrinker -> Theme engine widget -> DecorationEngineState engine -> [WindowDecoration] -> X ()
updateDecos :: forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationEngineState engine
-> [WindowDecoration]
-> X ()
updateDecos engine widget Window
engine shrinker
shrinker Theme engine widget
theme DecorationEngineState engine
decoState = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\WindowDecoration
wd -> forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationEngineState engine
-> WindowDecoration
-> Bool
-> X ()
updateDeco engine widget Window
engine shrinker
shrinker Theme engine widget
theme DecorationEngineState engine
decoState WindowDecoration
wd Bool
False)

-- | Update a decoration window given a shrinker, a theme, the font
-- structure and the needed 'Rectangle's
updateDeco :: (Shrinker shrinker, DecorationEngine engine widget Window) => engine widget Window -> shrinker -> Theme engine widget -> DecorationEngineState engine -> WindowDecoration -> Bool -> X ()
updateDeco :: forall shrinker (engine :: * -> * -> *) widget.
(Shrinker shrinker, DecorationEngine engine widget Window) =>
engine widget Window
-> shrinker
-> Theme engine widget
-> DecorationEngineState engine
-> WindowDecoration
-> Bool
-> X ()
updateDeco engine widget Window
engine shrinker
shrinker Theme engine widget
theme DecorationEngineState engine
decoState WindowDecoration
wd Bool
isExpose =
  case (WindowDecoration -> Maybe Window
wdDecoWindow WindowDecoration
wd, WindowDecoration -> Maybe Rectangle
wdDecoRect WindowDecoration
wd) of
    (Just Window
decoWindow, Just decoRect :: Rectangle
decoRect@(Rectangle Position
_ Position
_ Dimension
wh Dimension
ht)) -> do
      let origWin :: Window
origWin = WindowDecoration -> Window
wdOrigWindow WindowDecoration
wd
      DrawData engine widget
drawData <- 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 Window
engine Theme engine widget
theme DecorationEngineState engine
decoState Window
origWin Rectangle
decoRect
      WidgetLayout WidgetPlace
widgetPlaces <- forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> Theme engine widget
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Window
-> WidgetLayout widget
-> X (WidgetLayout WidgetPlace)
placeWidgets engine widget Window
engine Theme engine widget
theme shrinker
shrinker DecorationEngineState engine
decoState Rectangle
decoRect (WindowDecoration -> Window
wdOrigWindow WindowDecoration
wd) (forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme)
      -- io $ print widgetPlaces
      forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> a
-> Dimension
-> Dimension
-> shrinker
-> DrawData engine widget
-> Bool
-> X ()
paintDecoration engine widget Window
engine Window
decoWindow Dimension
wh Dimension
ht shrinker
shrinker (DrawData engine widget
drawData {ddWidgetPlaces :: WidgetLayout WidgetPlace
ddWidgetPlaces = WidgetLayout WidgetPlace
widgetPlaces}) Bool
isExpose
    (Just Window
decoWindow, Maybe Rectangle
Nothing) -> Window -> X ()
hideWindow Window
decoWindow
    (Maybe Window, Maybe Rectangle)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Apply a DecorationEx modifier to an underlying layout
decorationEx :: (DecorationEngine engine widget a, DecorationGeometry geom a, Shrinker shrinker)
             => shrinker             -- ^ Strings shrinker, for example @shrinkText@
             -> Theme engine widget  -- ^ Decoration theme
             -> engine widget a      -- ^ Decoration engine instance
             -> geom a               -- ^ Decoration geometry instance
             -> l a                  -- ^ Underlying layout to be decorated
             -> ModifiedLayout (DecorationEx engine widget geom shrinker) l a
decorationEx :: forall (engine :: * -> * -> *) widget a (geom :: * -> *) shrinker
       (l :: * -> *).
(DecorationEngine engine widget a, DecorationGeometry geom a,
 Shrinker shrinker) =>
shrinker
-> Theme engine widget
-> engine widget a
-> geom a
-> l a
-> ModifiedLayout (DecorationEx engine widget geom shrinker) l a
decorationEx shrinker
shrinker Theme engine widget
theme engine widget a
engine geom a
geom = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall (engine :: * -> * -> *) widget (geom :: * -> *) shrinker a.
Invisible Maybe (DecorationLayoutState engine)
-> shrinker
-> Theme engine widget
-> engine widget a
-> geom a
-> DecorationEx engine widget geom shrinker a
DecorationEx (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing) shrinker
shrinker Theme engine widget
theme engine widget a
engine geom a
geom)