{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards         #-}
{-# LANGUAGE CPP                   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Decoration
-- Description :  A layout modifier and a class for easily creating decorated layouts.
-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- A layout modifier and a class for easily creating decorated
-- layouts.
-----------------------------------------------------------------------------

module XMonad.Layout.Decoration
    ( -- * Usage:
      -- $usage
      decoration
    , Theme (..), def
    , Decoration
    , DecorationMsg (..)
    , DecorationStyle (..)
    , DefaultDecoration (..)
    , Shrinker (..), DefaultShrinker
    , shrinkText, CustomShrink ( CustomShrink ), shrinkWhile
    , isInStack, isVisible, isInvisible, isWithin, fi
    , findWindowByDecoration
    , module XMonad.Layout.LayoutModifier
    , DecorationState, OrigWin
    ) where

import Foreign.C.Types(CInt)

import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as W
import XMonad.Hooks.UrgencyHook
import XMonad.Layout.LayoutModifier
import XMonad.Layout.WindowArranger (WindowArrangerMsg (..), diff, listFromList)
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Invisible
import XMonad.Util.XUtils
import XMonad.Util.Font
import XMonad.Util.Image

-- $usage
-- This module is intended for layout developers, who want to decorate
-- their layouts. End users will not find here very much for them.
--
-- For examples of 'DecorationStyle' instances you can have a look at
-- "XMonad.Layout.SimpleDecoration", "XMonad.Layout.Tabbed",
-- "XMonad.Layout.DwmStyle", or "XMonad.Layout.TabBarDecoration".

-- | A layout modifier that, with a 'Shrinker', a 'Theme', a
-- 'DecorationStyle', and a layout, will decorate this layout
-- according to the decoration style provided.
--
-- For some usage examples see "XMonad.Layout.DecorationMadness".
decoration :: (DecorationStyle ds a, Shrinker s) => s -> Theme -> ds a
           -> l a -> ModifiedLayout (Decoration ds s) l a
decoration :: forall (ds :: * -> *) a s (l :: * -> *).
(DecorationStyle ds a, Shrinker s) =>
s -> Theme -> ds a -> l a -> ModifiedLayout (Decoration ds s) l a
decoration s
s Theme
t ds a
ds = Decoration ds s a -> l a -> ModifiedLayout (Decoration ds s) l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (Maybe DecorationState -> Invisible Maybe DecorationState
forall (m :: * -> *) a. m a -> Invisible m a
I Maybe DecorationState
forall a. Maybe a
Nothing) s
s Theme
t ds a
ds)

-- | A 'Theme' is a record of colors, font etc., to customize a
-- 'DecorationStyle'.
--
-- For a collection of 'Theme's see "XMonad.Util.Themes"
data Theme =
    Theme { Theme -> String
activeColor         :: String                  -- ^ Color of the active window
          , Theme -> String
inactiveColor       :: String                  -- ^ Color of the inactive window
          , Theme -> String
urgentColor         :: String                  -- ^ Color of the urgent window
          , Theme -> String
activeBorderColor   :: String                  -- ^ Color of the border of the active window
          , Theme -> String
inactiveBorderColor :: String                  -- ^ Color of the border of the inactive window
          , Theme -> String
urgentBorderColor   :: String                  -- ^ Color of the border of the urgent window
          , Theme -> Dimension
activeBorderWidth   :: Dimension               -- ^ Width of the border of the active window
          , Theme -> Dimension
inactiveBorderWidth :: Dimension               -- ^ Width of the border of the inactive window
          , Theme -> Dimension
urgentBorderWidth   :: Dimension               -- ^ Width of the border of the urgent window
          , Theme -> String
activeTextColor     :: String                  -- ^ Color of the text of the active window
          , Theme -> String
inactiveTextColor   :: String                  -- ^ Color of the text of the inactive window
          , Theme -> String
urgentTextColor     :: String                  -- ^ Color of the text of the urgent window
          , Theme -> String
fontName            :: String                  -- ^ Font name
          , Theme -> Dimension
decoWidth           :: Dimension               -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle')
          , Theme -> Dimension
decoHeight          :: Dimension               -- ^ Height of the decorations
          , Theme -> [(String, Align)]
windowTitleAddons   :: [(String, Align)]       -- ^ Extra text to appear in a window's title bar.
                                                           --    Refer to for a use "XMonad.Layout.ImageButtonDecoration"
          , Theme -> [([[Bool]], Placement)]
windowTitleIcons    :: [([[Bool]], Placement)] -- ^ Extra icons to appear in a window's title bar.
                                                           --    Inner @[Bool]@ is a row in a icon bitmap.
          } deriving (Int -> Theme -> ShowS
[Theme] -> ShowS
Theme -> String
(Int -> Theme -> ShowS)
-> (Theme -> String) -> ([Theme] -> ShowS) -> Show Theme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Theme] -> ShowS
$cshowList :: [Theme] -> ShowS
show :: Theme -> String
$cshow :: Theme -> String
showsPrec :: Int -> Theme -> ShowS
$cshowsPrec :: Int -> Theme -> ShowS
Show, ReadPrec [Theme]
ReadPrec Theme
Int -> ReadS Theme
ReadS [Theme]
(Int -> ReadS Theme)
-> ReadS [Theme]
-> ReadPrec Theme
-> ReadPrec [Theme]
-> Read Theme
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Theme]
$creadListPrec :: ReadPrec [Theme]
readPrec :: ReadPrec Theme
$creadPrec :: ReadPrec Theme
readList :: ReadS [Theme]
$creadList :: ReadS [Theme]
readsPrec :: Int -> ReadS Theme
$creadsPrec :: Int -> ReadS Theme
Read)

-- | The default xmonad 'Theme'.
instance Default Theme where
  def :: Theme
def =
    Theme :: String
-> String
-> String
-> String
-> String
-> String
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> String
-> String
-> Dimension
-> Dimension
-> [(String, Align)]
-> [([[Bool]], Placement)]
-> Theme
Theme { activeColor :: String
activeColor         = String
"#999999"
          , inactiveColor :: String
inactiveColor       = String
"#666666"
          , urgentColor :: String
urgentColor         = String
"#FFFF00"
          , activeBorderColor :: String
activeBorderColor   = String
"#FFFFFF"
          , inactiveBorderColor :: String
inactiveBorderColor = String
"#BBBBBB"
          , urgentBorderColor :: String
urgentBorderColor   = String
"##00FF00"
          , activeBorderWidth :: Dimension
activeBorderWidth   = Dimension
1
          , inactiveBorderWidth :: Dimension
inactiveBorderWidth = Dimension
1
          , urgentBorderWidth :: Dimension
urgentBorderWidth   = Dimension
1
          , activeTextColor :: String
activeTextColor     = String
"#FFFFFF"
          , inactiveTextColor :: String
inactiveTextColor   = String
"#BFBFBF"
          , urgentTextColor :: String
urgentTextColor     = String
"#FF0000"
#ifdef XFT
          , fontName :: String
fontName            = String
"xft:monospace"
#else
          , fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
#endif
          , decoWidth :: Dimension
decoWidth           = Dimension
200
          , decoHeight :: Dimension
decoHeight          = Dimension
20
          , windowTitleAddons :: [(String, Align)]
windowTitleAddons   = []
          , windowTitleIcons :: [([[Bool]], Placement)]
windowTitleIcons    = []
          }

-- | A 'Decoration' layout modifier will handle 'SetTheme', a message
-- to dynamically change the decoration 'Theme'.
newtype DecorationMsg = SetTheme Theme
instance Message DecorationMsg

-- | The 'Decoration' state component, where the list of decorated
-- window's is zipped with a list of decoration. A list of decoration
-- is a list of tuples, a 'Maybe' 'Window' and a 'Maybe Rectangle'.
-- The 'Window' will be displayed only if the rectangle is of type
-- 'Just'.
data DecorationState =
    DS { DecorationState -> [(OrigWin, DecoWin)]
decos :: [(OrigWin,DecoWin)]
       , DecorationState -> XMonadFont
font  :: XMonadFont
       }
type DecoWin = (Maybe Window, Maybe Rectangle)
type OrigWin = (Window,Rectangle)

-- | The 'Decoration' '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
-- 'DecorationStyle'.
data Decoration ds s a =
    Decoration (Invisible Maybe DecorationState) s Theme (ds a)
    deriving (Int -> Decoration ds s a -> ShowS
[Decoration ds s a] -> ShowS
Decoration ds s a -> String
(Int -> Decoration ds s a -> ShowS)
-> (Decoration ds s a -> String)
-> ([Decoration ds s a] -> ShowS)
-> Show (Decoration ds s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (ds :: * -> *) s a.
(Show s, Show (ds a)) =>
Int -> Decoration ds s a -> ShowS
forall (ds :: * -> *) s a.
(Show s, Show (ds a)) =>
[Decoration ds s a] -> ShowS
forall (ds :: * -> *) s a.
(Show s, Show (ds a)) =>
Decoration ds s a -> String
showList :: [Decoration ds s a] -> ShowS
$cshowList :: forall (ds :: * -> *) s a.
(Show s, Show (ds a)) =>
[Decoration ds s a] -> ShowS
show :: Decoration ds s a -> String
$cshow :: forall (ds :: * -> *) s a.
(Show s, Show (ds a)) =>
Decoration ds s a -> String
showsPrec :: Int -> Decoration ds s a -> ShowS
$cshowsPrec :: forall (ds :: * -> *) s a.
(Show s, Show (ds a)) =>
Int -> Decoration ds s a -> ShowS
Show, ReadPrec [Decoration ds s a]
ReadPrec (Decoration ds s a)
Int -> ReadS (Decoration ds s a)
ReadS [Decoration ds s a]
(Int -> ReadS (Decoration ds s a))
-> ReadS [Decoration ds s a]
-> ReadPrec (Decoration ds s a)
-> ReadPrec [Decoration ds s a]
-> Read (Decoration ds s a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
ReadPrec [Decoration ds s a]
forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
ReadPrec (Decoration ds s a)
forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
Int -> ReadS (Decoration ds s a)
forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
ReadS [Decoration ds s a]
readListPrec :: ReadPrec [Decoration ds s a]
$creadListPrec :: forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
ReadPrec [Decoration ds s a]
readPrec :: ReadPrec (Decoration ds s a)
$creadPrec :: forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
ReadPrec (Decoration ds s a)
readList :: ReadS [Decoration ds s a]
$creadList :: forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
ReadS [Decoration ds s a]
readsPrec :: Int -> ReadS (Decoration ds s a)
$creadsPrec :: forall (ds :: * -> *) s a.
(Read s, Read (ds a)) =>
Int -> ReadS (Decoration ds s a)
Read)

-- | The 'DecorationStyle' class, defines methods used in the
-- implementation of the 'Decoration' 'LayoutModifier' instance. A
-- type instance of this class is passed to the 'Decoration' type in
-- order to decorate a layout, by using these methods.
class (Read (ds a), Show (ds a), Eq a) => DecorationStyle ds a where

    -- | The description that the 'Decoration' modifier will display.
    describeDeco :: ds a -> String
    describeDeco = ds a -> String
forall a. Show a => a -> String
show

    -- | Shrink the window's rectangle when applying a decoration.
    shrink :: ds a -> Rectangle -> Rectangle -> Rectangle
    shrink ds a
_ (Rectangle Position
_ Position
_ Dimension
_ Dimension
dh) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x (Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
dh) Dimension
w (Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dh)

    -- | The decoration event hook
    decorationEventHook :: ds a -> DecorationState -> Event -> X ()
    decorationEventHook = ds a -> DecorationState -> Event -> X ()
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> DecorationState -> Event -> X ()
handleMouseFocusDrag

    -- | A hook that can be used to catch the cases when the user
    -- clicks on the decoration. If you return True here, the click event
    -- will be considered as dealt with and no further processing will take place.
    decorationCatchClicksHook :: ds a
                              -> Window
                              -> Int    -- ^ distance from the left where the click happened on the decoration
                              -> Int    -- ^ distance from the right where the click happened on the decoration
                              -> X Bool
    decorationCatchClicksHook ds a
_ Window
_ Int
_ Int
_ = Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    -- | This hook is called while a window is dragged using the decoration.
    -- The hook can be overwritten if a different way of handling the dragging
    -- is required.
    decorationWhileDraggingHook :: ds a -> CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
    decorationWhileDraggingHook ds a
_ = CInt -> CInt -> OrigWin -> Position -> Position -> X ()
handleDraggingInProgress

    -- | This hoook is called after a window has been dragged using the decoration.
    decorationAfterDraggingHook :: ds a -> (Window, Rectangle) -> Window -> X ()
    decorationAfterDraggingHook ds a
_ds (Window
mainw, Rectangle
_r) Window
_decoWin = Window -> X ()
focus Window
mainw

    -- | The pure version of the main method, 'decorate'.
    pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle
                   -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle
    pureDecoration ds a
_ Dimension
_ Dimension
ht Rectangle
_ Stack a
s [(a, Rectangle)]
_ (a
w,Rectangle Position
x Position
y Dimension
wh Dimension
ht') = if Stack a -> a -> Bool
forall a. Eq a => Stack a -> a -> Bool
isInStack Stack a
s a
w Bool -> Bool -> Bool
&& (Dimension
ht Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
ht')
                                                             then Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just (Rectangle -> Maybe Rectangle) -> Rectangle -> Maybe Rectangle
forall a b. (a -> b) -> a -> b
$ Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x Position
y Dimension
wh Dimension
ht
                                                             else Maybe Rectangle
forall a. Maybe a
Nothing

    -- | Given the theme's decoration width and height, the screen
    -- rectangle, the windows stack, the list of windows and
    -- rectangles returned by the underlying layout and window to be
    -- decorated, tupled with its rectangle, produce a 'Just'
    -- 'Rectangle' or 'Nothing' if the window is not to be decorated.
    decorate :: ds a -> Dimension -> Dimension -> Rectangle
             -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> X (Maybe Rectangle)
    decorate ds a
ds Dimension
w Dimension
h Rectangle
r Stack a
s [(a, Rectangle)]
wrs (a, Rectangle)
wr = Maybe Rectangle -> X (Maybe Rectangle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Rectangle -> X (Maybe Rectangle))
-> Maybe Rectangle -> X (Maybe Rectangle)
forall a b. (a -> b) -> a -> b
$ ds a
-> Dimension
-> Dimension
-> Rectangle
-> Stack a
-> [(a, Rectangle)]
-> (a, Rectangle)
-> Maybe Rectangle
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a
-> Dimension
-> Dimension
-> Rectangle
-> Stack a
-> [(a, Rectangle)]
-> (a, Rectangle)
-> Maybe Rectangle
pureDecoration ds a
ds Dimension
w Dimension
h Rectangle
r Stack a
s [(a, Rectangle)]
wrs (a, Rectangle)
wr

-- | The default 'DecorationStyle', with just the default methods'
-- implementations.
data DefaultDecoration a = DefaultDecoration deriving ( ReadPrec [DefaultDecoration a]
ReadPrec (DefaultDecoration a)
Int -> ReadS (DefaultDecoration a)
ReadS [DefaultDecoration a]
(Int -> ReadS (DefaultDecoration a))
-> ReadS [DefaultDecoration a]
-> ReadPrec (DefaultDecoration a)
-> ReadPrec [DefaultDecoration a]
-> Read (DefaultDecoration a)
forall a. ReadPrec [DefaultDecoration a]
forall a. ReadPrec (DefaultDecoration a)
forall a. Int -> ReadS (DefaultDecoration a)
forall a. ReadS [DefaultDecoration a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DefaultDecoration a]
$creadListPrec :: forall a. ReadPrec [DefaultDecoration a]
readPrec :: ReadPrec (DefaultDecoration a)
$creadPrec :: forall a. ReadPrec (DefaultDecoration a)
readList :: ReadS [DefaultDecoration a]
$creadList :: forall a. ReadS [DefaultDecoration a]
readsPrec :: Int -> ReadS (DefaultDecoration a)
$creadsPrec :: forall a. Int -> ReadS (DefaultDecoration a)
Read, Int -> DefaultDecoration a -> ShowS
[DefaultDecoration a] -> ShowS
DefaultDecoration a -> String
(Int -> DefaultDecoration a -> ShowS)
-> (DefaultDecoration a -> String)
-> ([DefaultDecoration a] -> ShowS)
-> Show (DefaultDecoration a)
forall a. Int -> DefaultDecoration a -> ShowS
forall a. [DefaultDecoration a] -> ShowS
forall a. DefaultDecoration a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultDecoration a] -> ShowS
$cshowList :: forall a. [DefaultDecoration a] -> ShowS
show :: DefaultDecoration a -> String
$cshow :: forall a. DefaultDecoration a -> String
showsPrec :: Int -> DefaultDecoration a -> ShowS
$cshowsPrec :: forall a. Int -> DefaultDecoration a -> ShowS
Show )
instance Eq a => DecorationStyle DefaultDecoration a

-- | The long 'LayoutModifier' instance for the 'Decoration' 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 'Decoration' 'LayoutModifier'. Otherwise we call
-- 'handleEvent', which will call the appropriate 'DecorationStyle'
-- methods to perform its tasks.
instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration ds s) Window where
    redoLayout :: Decoration ds s Window
-> Rectangle
-> Maybe (Stack Window)
-> [OrigWin]
-> X ([OrigWin], Maybe (Decoration ds s Window))
redoLayout (Decoration (I (Just DecorationState
s)) s
sh Theme
t ds Window
ds) Rectangle
_ Maybe (Stack Window)
Nothing [OrigWin]
_ = do
        DecorationState -> X ()
releaseResources DecorationState
s
        ([OrigWin], Maybe (Decoration ds s Window))
-> X ([OrigWin], Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Decoration ds s Window -> Maybe (Decoration ds s Window)
forall a. a -> Maybe a
Just (Decoration ds s Window -> Maybe (Decoration ds s Window))
-> Decoration ds s Window -> Maybe (Decoration ds s Window)
forall a b. (a -> b) -> a -> b
$ Invisible Maybe DecorationState
-> s -> Theme -> ds Window -> Decoration ds s Window
forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (Maybe DecorationState -> Invisible Maybe DecorationState
forall (m :: * -> *) a. m a -> Invisible m a
I Maybe DecorationState
forall a. Maybe a
Nothing) s
sh Theme
t ds Window
ds)
    redoLayout Decoration ds s Window
_                                 Rectangle
_ Maybe (Stack Window)
Nothing [OrigWin]
_  = ([OrigWin], Maybe (Decoration ds s Window))
-> X ([OrigWin], Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe (Decoration ds s Window)
forall a. Maybe a
Nothing)

    redoLayout (Decoration Invisible Maybe DecorationState
st s
sh Theme
t ds Window
ds) Rectangle
sc (Just Stack Window
stack) [OrigWin]
wrs
        | I Maybe DecorationState
Nothing  <- Invisible Maybe DecorationState
st = Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> X DecorationState
forall (ds :: * -> *).
DecorationStyle ds Window =>
Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> X DecorationState
initState Theme
t ds Window
ds Rectangle
sc Stack Window
stack [OrigWin]
wrs X DecorationState
-> (DecorationState
    -> X ([OrigWin], Maybe (Decoration ds s Window)))
-> X ([OrigWin], Maybe (Decoration ds s Window))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DecorationState -> X ([OrigWin], Maybe (Decoration ds s Window))
processState
        | I (Just DecorationState
s) <- Invisible Maybe DecorationState
st = do let dwrs :: [(OrigWin, DecoWin)]
dwrs  = DecorationState -> [(OrigWin, DecoWin)]
decos DecorationState
s
                                    ([Window]
d,[Window]
a) = (([Window], [Window]) -> ([Window], [Window]))
-> [Window] -> [Window] -> ([Window], [Window])
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ([Window], [Window]) -> ([Window], [Window])
forall a. Eq a => ([a], [a]) -> ([a], [a])
diff ([(OrigWin, DecoWin)] -> [Window]
forall {b} {b} {b}. [((b, b), b)] -> [b]
get_ws [(OrigWin, DecoWin)]
dwrs) [Window]
ws
                                    toDel :: [(OrigWin, DecoWin)]
toDel = [Window] -> [(OrigWin, DecoWin)] -> [(OrigWin, DecoWin)]
forall {t :: * -> *} {b} {b} {b}.
(Foldable t, Eq b) =>
t b -> [((b, b), b)] -> [((b, b), b)]
todel [Window]
d [(OrigWin, DecoWin)]
dwrs
                                    toAdd :: [OrigWin]
toAdd = [Window] -> [OrigWin] -> [OrigWin]
forall {t :: * -> *} {b} {b}.
(Foldable t, Eq b) =>
t b -> [(b, b)] -> [(b, b)]
toadd [Window]
a [OrigWin]
wrs
                                [DecoWin] -> X ()
deleteDecos (((OrigWin, DecoWin) -> DecoWin)
-> [(OrigWin, DecoWin)] -> [DecoWin]
forall a b. (a -> b) -> [a] -> [b]
map (OrigWin, DecoWin) -> DecoWin
forall a b. (a, b) -> b
snd [(OrigWin, DecoWin)]
toDel)
                                let ndwrs :: [(OrigWin, (Maybe a, Maybe a))]
ndwrs = [OrigWin]
-> [(Maybe a, Maybe a)] -> [(OrigWin, (Maybe a, Maybe a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [OrigWin]
toAdd ([(Maybe a, Maybe a)] -> [(OrigWin, (Maybe a, Maybe a))])
-> [(Maybe a, Maybe a)] -> [(OrigWin, (Maybe a, Maybe a))]
forall a b. (a -> b) -> a -> b
$ (Maybe a, Maybe a) -> [(Maybe a, Maybe a)]
forall a. a -> [a]
repeat (Maybe a
forall a. Maybe a
Nothing,Maybe a
forall a. Maybe a
Nothing)
                                [(OrigWin, DecoWin)]
ndecos <- [(OrigWin, DecoWin)] -> [OrigWin] -> X [(OrigWin, DecoWin)]
forall {b} {b}.
[((Window, b), (Maybe Window, b))]
-> [OrigWin] -> X [(OrigWin, DecoWin)]
resync ([(OrigWin, DecoWin)]
forall {a} {a}. [(OrigWin, (Maybe a, Maybe a))]
ndwrs [(OrigWin, DecoWin)]
-> [(OrigWin, DecoWin)] -> [(OrigWin, DecoWin)]
forall a. [a] -> [a] -> [a]
++ [Window] -> [(OrigWin, DecoWin)] -> [(OrigWin, DecoWin)]
forall {b} {b}.
[Window] -> [((Window, b), b)] -> [((Window, b), b)]
del_dwrs [Window]
d [(OrigWin, DecoWin)]
dwrs) [OrigWin]
wrs
                                DecorationState -> X ([OrigWin], Maybe (Decoration ds s Window))
processState (DecorationState
s {decos :: [(OrigWin, DecoWin)]
decos = [(OrigWin, DecoWin)]
ndecos })

        where
          ws :: [Window]
ws        = (OrigWin -> Window) -> [OrigWin] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map OrigWin -> Window
forall a b. (a, b) -> a
fst [OrigWin]
wrs
          get_w :: ((c, b), b) -> c
get_w     = (c, b) -> c
forall a b. (a, b) -> a
fst ((c, b) -> c) -> (((c, b), b) -> (c, b)) -> ((c, b), b) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((c, b), b) -> (c, b)
forall a b. (a, b) -> a
fst
          get_ws :: [((b, b), b)] -> [b]
get_ws    = (((b, b), b) -> b) -> [((b, b), b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map ((b, b), b) -> b
forall {c} {b} {b}. ((c, b), b) -> c
get_w
          del_dwrs :: [Window] -> [((Window, b), b)] -> [((Window, b), b)]
del_dwrs  = (((Window, b), b) -> Window)
-> (Window -> [Window] -> Bool)
-> [Window]
-> [((Window, b), b)]
-> [((Window, b), b)]
forall b c a. (b -> c) -> (c -> [a] -> Bool) -> [a] -> [b] -> [b]
listFromList ((Window, b), b) -> Window
forall {c} {b} {b}. ((c, b), b) -> c
get_w Window -> [Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem
          find_dw :: Int -> [(a, (c, b))] -> c
find_dw Int
i = (c, b) -> c
forall a b. (a, b) -> a
fst ((c, b) -> c) -> ([(a, (c, b))] -> (c, b)) -> [(a, (c, b))] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (c, b)) -> (c, b)
forall a b. (a, b) -> b
snd ((a, (c, b)) -> (c, b))
-> ([(a, (c, b))] -> (a, (c, b))) -> [(a, (c, b))] -> (c, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, (c, b))] -> Int -> (a, (c, b)))
-> Int -> [(a, (c, b))] -> (a, (c, b))
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(a, (c, b))] -> Int -> (a, (c, b))
forall a. [a] -> Int -> a
(!!) Int
i
          todel :: t b -> [((b, b), b)] -> [((b, b), b)]
todel   t b
d = (((b, b), b) -> Bool) -> [((b, b), b)] -> [((b, b), b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> t b -> Bool) -> t b -> b -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> t b -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem t b
d (b -> Bool) -> (((b, b), b) -> b) -> ((b, b), b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, b), b) -> b
forall {c} {b} {b}. ((c, b), b) -> c
get_w)
          toadd :: t b -> [(b, b)] -> [(b, b)]
toadd   t b
a = ((b, b) -> Bool) -> [(b, b)] -> [(b, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> t b -> Bool) -> t b -> b -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> t b -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem t b
a (b -> Bool) -> ((b, b) -> b) -> (b, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, b) -> b
forall a b. (a, b) -> a
fst  )

          check_dwr :: DecoWin -> X DecoWin
check_dwr DecoWin
dwr = case DecoWin
dwr of
                            (Maybe Window
Nothing, Just Rectangle
dr) -> do Window
dw <- Theme -> Rectangle -> X Window
createDecoWindow Theme
t Rectangle
dr
                                                     DecoWin -> X DecoWin
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> Maybe Window
forall a. a -> Maybe a
Just Window
dw, Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just Rectangle
dr)
                            DecoWin
_                 -> DecoWin -> X DecoWin
forall (m :: * -> *) a. Monad m => a -> m a
return DecoWin
dwr

          resync :: [((Window, b), (Maybe Window, b))]
-> [OrigWin] -> X [(OrigWin, DecoWin)]
resync [((Window, b), (Maybe Window, b))]
_         [] = [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
          resync [((Window, b), (Maybe Window, b))]
d ((Window
w,Rectangle
r):[OrigWin]
xs) = case  Window
w Window -> [Window] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [((Window, b), (Maybe Window, b))] -> [Window]
forall {b} {b} {b}. [((b, b), b)] -> [b]
get_ws [((Window, b), (Maybe Window, b))]
d of
                                  Just Int
i  -> do Maybe Rectangle
dr   <- ds Window
-> Dimension
-> Dimension
-> Rectangle
-> Stack Window
-> [OrigWin]
-> OrigWin
-> X (Maybe Rectangle)
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a
-> Dimension
-> Dimension
-> Rectangle
-> Stack a
-> [(a, Rectangle)]
-> (a, Rectangle)
-> X (Maybe Rectangle)
decorate ds Window
ds (Theme -> Dimension
decoWidth Theme
t) (Theme -> Dimension
decoHeight Theme
t) Rectangle
sc Stack Window
stack [OrigWin]
wrs (Window
w,Rectangle
r)
                                                DecoWin
dwr  <- DecoWin -> X DecoWin
check_dwr (Int -> [((Window, b), (Maybe Window, b))] -> Maybe Window
forall {a} {c} {b}. Int -> [(a, (c, b))] -> c
find_dw Int
i [((Window, b), (Maybe Window, b))]
d, Maybe Rectangle
dr)
                                                [(OrigWin, DecoWin)]
dwrs <- [((Window, b), (Maybe Window, b))]
-> [OrigWin] -> X [(OrigWin, DecoWin)]
resync [((Window, b), (Maybe Window, b))]
d [OrigWin]
xs
                                                [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)])
-> [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall a b. (a -> b) -> a -> b
$ ((Window
w,Rectangle
r),DecoWin
dwr) (OrigWin, DecoWin) -> [(OrigWin, DecoWin)] -> [(OrigWin, DecoWin)]
forall a. a -> [a] -> [a]
: [(OrigWin, DecoWin)]
dwrs
                                  Maybe Int
Nothing -> [((Window, b), (Maybe Window, b))]
-> [OrigWin] -> X [(OrigWin, DecoWin)]
resync [((Window, b), (Maybe Window, b))]
d [OrigWin]
xs

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

          insert_dwr :: ((a, Rectangle), (Maybe a, Maybe Rectangle))
-> [(a, Rectangle)] -> [(a, Rectangle)]
insert_dwr ((a
w,Rectangle
r),(Just a
dw,Just Rectangle
dr)) [(a, Rectangle)]
xs = (a
dw,Rectangle
dr)(a, Rectangle) -> [(a, Rectangle)] -> [(a, Rectangle)]
forall a. a -> [a] -> [a]
:(a
w, ds Window -> Rectangle -> Rectangle -> Rectangle
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> Rectangle -> Rectangle -> Rectangle
shrink ds Window
ds Rectangle
dr Rectangle
r)(a, Rectangle) -> [(a, Rectangle)] -> [(a, Rectangle)]
forall a. a -> [a] -> [a]
:[(a, Rectangle)]
xs
          insert_dwr ((a, Rectangle)
x    ,(     Maybe a
_ ,     Maybe Rectangle
_ )) [(a, Rectangle)]
xs = (a, Rectangle)
x(a, Rectangle) -> [(a, Rectangle)] -> [(a, Rectangle)]
forall a. a -> [a] -> [a]
:[(a, Rectangle)]
xs

          dwrs_to_wrs :: [((a, Rectangle), (Maybe a, Maybe Rectangle))] -> [(a, Rectangle)]
dwrs_to_wrs    = [Rectangle] -> [(a, Rectangle)] -> [(a, Rectangle)]
forall {a} {a}. Eq a => [a] -> [(a, a)] -> [(a, a)]
remove_stacked [] ([(a, Rectangle)] -> [(a, Rectangle)])
-> ([((a, Rectangle), (Maybe a, Maybe Rectangle))]
    -> [(a, Rectangle)])
-> [((a, Rectangle), (Maybe a, Maybe Rectangle))]
-> [(a, Rectangle)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a, Rectangle), (Maybe a, Maybe Rectangle))
 -> [(a, Rectangle)] -> [(a, Rectangle)])
-> [(a, Rectangle)]
-> [((a, Rectangle), (Maybe a, Maybe Rectangle))]
-> [(a, Rectangle)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a, Rectangle), (Maybe a, Maybe Rectangle))
-> [(a, Rectangle)] -> [(a, Rectangle)]
forall {a}.
((a, Rectangle), (Maybe a, Maybe Rectangle))
-> [(a, Rectangle)] -> [(a, Rectangle)]
insert_dwr []

          processState :: DecorationState -> X ([OrigWin], Maybe (Decoration ds s Window))
processState DecorationState
s = do let ndwrs :: [(OrigWin, DecoWin)]
ndwrs = DecorationState -> [(OrigWin, DecoWin)]
decos DecorationState
s
                              [DecoWin] -> X ()
showDecos (((OrigWin, DecoWin) -> DecoWin)
-> [(OrigWin, DecoWin)] -> [DecoWin]
forall a b. (a -> b) -> [a] -> [b]
map (OrigWin, DecoWin) -> DecoWin
forall a b. (a, b) -> b
snd [(OrigWin, DecoWin)]
ndwrs)
                              s -> Theme -> XMonadFont -> [(OrigWin, DecoWin)] -> X ()
forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> [(OrigWin, DecoWin)] -> X ()
updateDecos s
sh Theme
t (DecorationState -> XMonadFont
font DecorationState
s) [(OrigWin, DecoWin)]
ndwrs
                              ([OrigWin], Maybe (Decoration ds s Window))
-> X ([OrigWin], Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OrigWin, DecoWin)] -> [OrigWin]
forall {a}.
[((a, Rectangle), (Maybe a, Maybe Rectangle))] -> [(a, Rectangle)]
dwrs_to_wrs [(OrigWin, DecoWin)]
ndwrs, Decoration ds s Window -> Maybe (Decoration ds s Window)
forall a. a -> Maybe a
Just (Invisible Maybe DecorationState
-> s -> Theme -> ds Window -> Decoration ds s Window
forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (Maybe DecorationState -> Invisible Maybe DecorationState
forall (m :: * -> *) a. m a -> Invisible m a
I (DecorationState -> Maybe DecorationState
forall a. a -> Maybe a
Just (DecorationState
s {decos :: [(OrigWin, DecoWin)]
decos = [(OrigWin, DecoWin)]
ndwrs}))) s
sh Theme
t ds Window
ds))

    handleMess :: Decoration ds s Window
-> SomeMessage -> X (Maybe (Decoration ds s Window))
handleMess (Decoration (I (Just s :: DecorationState
s@DS{decos :: DecorationState -> [(OrigWin, DecoWin)]
decos = [(OrigWin, DecoWin)]
dwrs})) s
sh Theme
t ds Window
ds) SomeMessage
m
        | Just Event
e <- SomeMessage -> Maybe Event
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m                = do ds Window -> DecorationState -> Event -> X ()
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> DecorationState -> Event -> X ()
decorationEventHook ds Window
ds DecorationState
s Event
e
                                                      s -> Theme -> DecorationState -> Event -> X ()
forall s.
Shrinker s =>
s -> Theme -> DecorationState -> Event -> X ()
handleEvent s
sh Theme
t DecorationState
s Event
e
                                                      Maybe (Decoration ds s Window)
-> X (Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Decoration ds s Window)
forall a. Maybe a
Nothing
        | Just LayoutMessages
Hide             <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do [DecoWin] -> X ()
hideDecos (((OrigWin, DecoWin) -> DecoWin)
-> [(OrigWin, DecoWin)] -> [DecoWin]
forall a b. (a -> b) -> [a] -> [b]
map (OrigWin, DecoWin) -> DecoWin
forall a b. (a, b) -> b
snd [(OrigWin, DecoWin)]
dwrs)
                                                      Maybe (Decoration ds s Window)
-> X (Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Decoration ds s Window)
forall a. Maybe a
Nothing
        | Just (SetTheme Theme
nt)    <- SomeMessage -> Maybe DecorationMsg
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do DecorationState -> X ()
releaseResources DecorationState
s
                                                      Maybe (Decoration ds s Window)
-> X (Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Decoration ds s Window)
 -> X (Maybe (Decoration ds s Window)))
-> Maybe (Decoration ds s Window)
-> X (Maybe (Decoration ds s Window))
forall a b. (a -> b) -> a -> b
$ Decoration ds s Window -> Maybe (Decoration ds s Window)
forall a. a -> Maybe a
Just (Decoration ds s Window -> Maybe (Decoration ds s Window))
-> Decoration ds s Window -> Maybe (Decoration ds s Window)
forall a b. (a -> b) -> a -> b
$ Invisible Maybe DecorationState
-> s -> Theme -> ds Window -> Decoration ds s Window
forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (Maybe DecorationState -> Invisible Maybe DecorationState
forall (m :: * -> *) a. m a -> Invisible m a
I Maybe DecorationState
forall a. Maybe a
Nothing) s
sh Theme
nt ds Window
ds
        | Just LayoutMessages
ReleaseResources <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do DecorationState -> X ()
releaseResources DecorationState
s
                                                      Maybe (Decoration ds s Window)
-> X (Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Decoration ds s Window)
 -> X (Maybe (Decoration ds s Window)))
-> Maybe (Decoration ds s Window)
-> X (Maybe (Decoration ds s Window))
forall a b. (a -> b) -> a -> b
$ Decoration ds s Window -> Maybe (Decoration ds s Window)
forall a. a -> Maybe a
Just (Decoration ds s Window -> Maybe (Decoration ds s Window))
-> Decoration ds s Window -> Maybe (Decoration ds s Window)
forall a b. (a -> b) -> a -> b
$ Invisible Maybe DecorationState
-> s -> Theme -> ds Window -> Decoration ds s Window
forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (Maybe DecorationState -> Invisible Maybe DecorationState
forall (m :: * -> *) a. m a -> Invisible m a
I Maybe DecorationState
forall a. Maybe a
Nothing) s
sh Theme
t  ds Window
ds
    handleMess Decoration ds s Window
_ SomeMessage
_ = Maybe (Decoration ds s Window)
-> X (Maybe (Decoration ds s Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Decoration ds s Window)
forall a. Maybe a
Nothing

    modifierDescription :: Decoration ds s Window -> String
modifierDescription (Decoration Invisible Maybe DecorationState
_ s
_ Theme
_ ds Window
ds) = ds Window -> String
forall (ds :: * -> *) a. DecorationStyle ds a => ds a -> String
describeDeco ds Window
ds

-- | By default 'Decoration' handles 'PropertyEvent' and 'ExposeEvent'
-- only.
handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X ()
handleEvent :: forall s.
Shrinker s =>
s -> Theme -> DecorationState -> Event -> X ()
handleEvent s
sh Theme
t (DS [(OrigWin, DecoWin)]
dwrs XMonadFont
fs) Event
e
    | PropertyEvent {ev_window :: Event -> Window
ev_window = Window
w} <- Event
e
    , Just Int
i <- Window
w Window -> [Window] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` ((OrigWin, DecoWin) -> Window) -> [(OrigWin, DecoWin)] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map (OrigWin -> Window
forall a b. (a, b) -> a
fst (OrigWin -> Window)
-> ((OrigWin, DecoWin) -> OrigWin) -> (OrigWin, DecoWin) -> Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OrigWin, DecoWin) -> OrigWin
forall a b. (a, b) -> a
fst) [(OrigWin, DecoWin)]
dwrs      = s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
updateDeco s
sh Theme
t XMonadFont
fs ([(OrigWin, DecoWin)]
dwrs [(OrigWin, DecoWin)] -> Int -> (OrigWin, DecoWin)
forall a. [a] -> Int -> a
!! Int
i)
    | ExposeEvent   {ev_window :: Event -> Window
ev_window = Window
w} <- Event
e
    , Just Int
i <- Window
w Window -> [Window] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` ((OrigWin, DecoWin) -> Maybe Window)
-> [(OrigWin, DecoWin)] -> [Window]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DecoWin -> Maybe Window
forall a b. (a, b) -> a
fst (DecoWin -> Maybe Window)
-> ((OrigWin, DecoWin) -> DecoWin)
-> (OrigWin, DecoWin)
-> Maybe Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OrigWin, DecoWin) -> DecoWin
forall a b. (a, b) -> b
snd) [(OrigWin, DecoWin)]
dwrs = s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
updateDeco s
sh Theme
t XMonadFont
fs ([(OrigWin, DecoWin)]
dwrs [(OrigWin, DecoWin)] -> Int -> (OrigWin, DecoWin)
forall a. [a] -> Int -> a
!! Int
i)
handleEvent s
_ Theme
_ DecorationState
_ Event
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Mouse focus and mouse drag are handled by the same function, this
-- way we can start dragging unfocused windows too.
handleMouseFocusDrag :: (DecorationStyle ds a) => ds a -> DecorationState -> Event -> X ()
handleMouseFocusDrag :: forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> DecorationState -> Event -> X ()
handleMouseFocusDrag ds a
ds (DS [(OrigWin, DecoWin)]
dwrs XMonadFont
_) ButtonEvent { ev_window :: Event -> Window
ev_window     = Window
ew
                                                , ev_event_type :: Event -> Dimension
ev_event_type = Dimension
et
                                                , ev_x_root :: Event -> CInt
ev_x_root     = CInt
ex
                                                , ev_y_root :: Event -> CInt
ev_y_root     = CInt
ey }
    | Dimension
et Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
buttonPress
    , Just ((Window
mainw,Rectangle
r), (Window
_, Maybe Rectangle
decoRectM)) <- Window
-> [(OrigWin, DecoWin)]
-> Maybe (OrigWin, (Window, Maybe Rectangle))
lookFor Window
ew [(OrigWin, DecoWin)]
dwrs = do
        let Rectangle Position
dx Position
_ Dimension
dwh Dimension
_ = Maybe Rectangle -> Rectangle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Rectangle
decoRectM
            distFromLeft :: CInt
distFromLeft = CInt
ex CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Position
dx
            distFromRight :: CInt
distFromRight = Dimension -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Dimension
dwh CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- (CInt
ex CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Position
dx)
        Bool
dealtWith <- ds a -> Window -> Int -> Int -> X Bool
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> Window -> Int -> Int -> X Bool
decorationCatchClicksHook ds a
ds Window
mainw (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fi CInt
distFromLeft) (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fi CInt
distFromRight)
        Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dealtWith (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
x Position
y -> Window -> X ()
focus Window
mainw X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ds a -> CInt -> CInt -> OrigWin -> Position -> Position -> X ()
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> CInt -> CInt -> OrigWin -> Position -> Position -> X ()
decorationWhileDraggingHook ds a
ds CInt
ex CInt
ey (Window
mainw, Rectangle
r) Position
x Position
y)
                        (ds a -> OrigWin -> Window -> X ()
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> OrigWin -> Window -> X ()
decorationAfterDraggingHook ds a
ds (Window
mainw, Rectangle
r) Window
ew)
handleMouseFocusDrag ds a
_ DecorationState
_ Event
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
handleDraggingInProgress :: CInt -> CInt -> OrigWin -> Position -> Position -> X ()
handleDraggingInProgress CInt
ex CInt
ey (Window
_, 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)
    WindowArrangerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage (WindowArrangerMsg -> X ()) -> WindowArrangerMsg -> X ()
forall a b. (a -> b) -> a -> b
$ Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect

-- | Given a window and the state, if a matching decoration is in the
-- state return it with its ('Maybe') 'Rectangle'.
lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle))
lookFor :: Window
-> [(OrigWin, DecoWin)]
-> Maybe (OrigWin, (Window, Maybe Rectangle))
lookFor Window
w ((OrigWin
wr,(Just Window
dw,Maybe Rectangle
dr)):[(OrigWin, DecoWin)]
dwrs) | Window
w Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
dw = (OrigWin, (Window, Maybe Rectangle))
-> Maybe (OrigWin, (Window, Maybe Rectangle))
forall a. a -> Maybe a
Just (OrigWin
wr,(Window
dw,Maybe Rectangle
dr))
                                   | Bool
otherwise = Window
-> [(OrigWin, DecoWin)]
-> Maybe (OrigWin, (Window, Maybe Rectangle))
lookFor Window
w [(OrigWin, DecoWin)]
dwrs
lookFor Window
w ((OrigWin
_, (Maybe Window
Nothing, Maybe Rectangle
_)):[(OrigWin, DecoWin)]
dwrs) = Window
-> [(OrigWin, DecoWin)]
-> Maybe (OrigWin, (Window, Maybe Rectangle))
lookFor Window
w [(OrigWin, DecoWin)]
dwrs
lookFor Window
_ [] = Maybe (OrigWin, (Window, Maybe Rectangle))
forall a. Maybe a
Nothing

findWindowByDecoration :: Window -> DecorationState -> Maybe (OrigWin,(Window,Maybe Rectangle))
findWindowByDecoration :: Window
-> DecorationState -> Maybe (OrigWin, (Window, Maybe Rectangle))
findWindowByDecoration Window
w DecorationState
ds = Window
-> [(OrigWin, DecoWin)]
-> Maybe (OrigWin, (Window, Maybe Rectangle))
lookFor Window
w (DecorationState -> [(OrigWin, DecoWin)]
decos DecorationState
ds)

-- | Initialize the 'DecorationState' by initializing the font
-- structure and by creating the needed decorations.
initState :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle
          -> W.Stack Window -> [(Window,Rectangle)] -> X DecorationState
initState :: forall (ds :: * -> *).
DecorationStyle ds Window =>
Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> X DecorationState
initState Theme
t ds Window
ds Rectangle
sc Stack Window
s [OrigWin]
wrs = do
  XMonadFont
fs   <- String -> X XMonadFont
initXMF (Theme -> String
fontName Theme
t)
  [(OrigWin, DecoWin)]
dwrs <- Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> [OrigWin]
-> X [(OrigWin, DecoWin)]
forall (ds :: * -> *).
DecorationStyle ds Window =>
Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> [OrigWin]
-> X [(OrigWin, DecoWin)]
createDecos Theme
t ds Window
ds Rectangle
sc Stack Window
s [OrigWin]
wrs [OrigWin]
wrs
  DecorationState -> X DecorationState
forall (m :: * -> *) a. Monad m => a -> m a
return (DecorationState -> X DecorationState)
-> DecorationState -> X DecorationState
forall a b. (a -> b) -> a -> b
$ [(OrigWin, DecoWin)] -> XMonadFont -> DecorationState
DS [(OrigWin, DecoWin)]
dwrs XMonadFont
fs

-- | Delete windows stored in the state and release the font structure.
releaseResources :: DecorationState -> X ()
releaseResources :: DecorationState -> X ()
releaseResources DecorationState
s = do
  [DecoWin] -> X ()
deleteDecos (((OrigWin, DecoWin) -> DecoWin)
-> [(OrigWin, DecoWin)] -> [DecoWin]
forall a b. (a -> b) -> [a] -> [b]
map (OrigWin, DecoWin) -> DecoWin
forall a b. (a, b) -> b
snd ([(OrigWin, DecoWin)] -> [DecoWin])
-> [(OrigWin, DecoWin)] -> [DecoWin]
forall a b. (a -> b) -> a -> b
$ DecorationState -> [(OrigWin, DecoWin)]
decos DecorationState
s)
  XMonadFont -> X ()
releaseXMF  (DecorationState -> XMonadFont
font DecorationState
s)

-- | Create the decoration windows of a list of windows and their
-- rectangles, by calling the 'decorate' method of the
-- 'DecorationStyle' received.
createDecos :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle -> W.Stack Window
            -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)]
createDecos :: forall (ds :: * -> *).
DecorationStyle ds Window =>
Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> [OrigWin]
-> X [(OrigWin, DecoWin)]
createDecos Theme
t ds Window
ds Rectangle
sc Stack Window
s [OrigWin]
wrs ((Window
w,Rectangle
r):[OrigWin]
xs) = do
  Maybe Rectangle
deco <- ds Window
-> Dimension
-> Dimension
-> Rectangle
-> Stack Window
-> [OrigWin]
-> OrigWin
-> X (Maybe Rectangle)
forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a
-> Dimension
-> Dimension
-> Rectangle
-> Stack a
-> [(a, Rectangle)]
-> (a, Rectangle)
-> X (Maybe Rectangle)
decorate ds Window
ds (Theme -> Dimension
decoWidth Theme
t) (Theme -> Dimension
decoHeight Theme
t) Rectangle
sc Stack Window
s [OrigWin]
wrs (Window
w,Rectangle
r)
  case Maybe Rectangle
deco of
    Just Rectangle
dr -> do Window
dw   <- Theme -> Rectangle -> X Window
createDecoWindow Theme
t Rectangle
dr
                  [(OrigWin, DecoWin)]
dwrs <- Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> [OrigWin]
-> X [(OrigWin, DecoWin)]
forall (ds :: * -> *).
DecorationStyle ds Window =>
Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> [OrigWin]
-> X [(OrigWin, DecoWin)]
createDecos Theme
t ds Window
ds Rectangle
sc Stack Window
s [OrigWin]
wrs [OrigWin]
xs
                  [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)])
-> [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall a b. (a -> b) -> a -> b
$ ((Window
w,Rectangle
r), (Window -> Maybe Window
forall a. a -> Maybe a
Just Window
dw, Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just Rectangle
dr)) (OrigWin, DecoWin) -> [(OrigWin, DecoWin)] -> [(OrigWin, DecoWin)]
forall a. a -> [a] -> [a]
: [(OrigWin, DecoWin)]
dwrs
    Maybe Rectangle
Nothing -> do [(OrigWin, DecoWin)]
dwrs <- Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> [OrigWin]
-> X [(OrigWin, DecoWin)]
forall (ds :: * -> *).
DecorationStyle ds Window =>
Theme
-> ds Window
-> Rectangle
-> Stack Window
-> [OrigWin]
-> [OrigWin]
-> X [(OrigWin, DecoWin)]
createDecos Theme
t ds Window
ds Rectangle
sc Stack Window
s [OrigWin]
wrs [OrigWin]
xs
                  [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)])
-> [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall a b. (a -> b) -> a -> b
$ ((Window
w,Rectangle
r), (Maybe Window
forall a. Maybe a
Nothing, Maybe Rectangle
forall a. Maybe a
Nothing)) (OrigWin, DecoWin) -> [(OrigWin, DecoWin)] -> [(OrigWin, DecoWin)]
forall a. a -> [a] -> [a]
: [(OrigWin, DecoWin)]
dwrs
createDecos Theme
_ ds Window
_ Rectangle
_ Stack Window
_ [OrigWin]
_ [] = [(OrigWin, DecoWin)] -> X [(OrigWin, DecoWin)]
forall (m :: * -> *) a. Monad m => a -> m a
return []

createDecoWindow :: Theme -> Rectangle -> X Window
createDecoWindow :: Theme -> Rectangle -> X Window
createDecoWindow Theme
t Rectangle
r = do
  let mask :: Maybe Window
mask = Window -> Maybe Window
forall a. a -> Maybe a
Just (Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonPressMask)
  Window
w <- Rectangle -> Maybe Window -> String -> Bool -> X Window
createNewWindow Rectangle
r Maybe Window
mask (Theme -> String
inactiveColor Theme
t) Bool
True
  Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> ClassHint -> IO ()
setClassHint Display
d Window
w (String -> String -> ClassHint
ClassHint String
"xmonad-decoration" String
"xmonad")
  Window -> X Window
forall (f :: * -> *) a. Applicative f => a -> f a
pure Window
w

showDecos :: [DecoWin] -> X ()
showDecos :: [DecoWin] -> X ()
showDecos = [Window] -> X ()
showWindows ([Window] -> X ()) -> ([DecoWin] -> [Window]) -> [DecoWin] -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecoWin -> Maybe Window) -> [DecoWin] -> [Window]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DecoWin -> Maybe Window
forall a b. (a, b) -> a
fst ([DecoWin] -> [Window])
-> ([DecoWin] -> [DecoWin]) -> [DecoWin] -> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecoWin -> Bool) -> [DecoWin] -> [DecoWin]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Rectangle -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Rectangle -> Bool)
-> (DecoWin -> Maybe Rectangle) -> DecoWin -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoWin -> Maybe Rectangle
forall a b. (a, b) -> b
snd)

hideDecos :: [DecoWin] -> X ()
hideDecos :: [DecoWin] -> X ()
hideDecos = [Window] -> X ()
hideWindows ([Window] -> X ()) -> ([DecoWin] -> [Window]) -> [DecoWin] -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecoWin -> Maybe Window) -> [DecoWin] -> [Window]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DecoWin -> Maybe Window
forall a b. (a, b) -> a
fst

deleteDecos :: [DecoWin] -> X ()
deleteDecos :: [DecoWin] -> X ()
deleteDecos = [Window] -> X ()
deleteWindows ([Window] -> X ()) -> ([DecoWin] -> [Window]) -> [DecoWin] -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecoWin -> Maybe Window) -> [DecoWin] -> [Window]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DecoWin -> Maybe Window
forall a b. (a, b) -> a
fst

updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X ()
updateDecos :: forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> [(OrigWin, DecoWin)] -> X ()
updateDecos s
s Theme
t XMonadFont
f = ((OrigWin, DecoWin) -> X ()) -> [(OrigWin, DecoWin)] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((OrigWin, DecoWin) -> X ()) -> [(OrigWin, DecoWin)] -> X ())
-> ((OrigWin, DecoWin) -> X ()) -> [(OrigWin, DecoWin)] -> X ()
forall a b. (a -> b) -> a -> b
$ s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
updateDeco s
s Theme
t XMonadFont
f

-- | Update a decoration window given a shrinker, a theme, the font
-- structure and the needed 'Rectangle's
updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X ()
updateDeco :: forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
updateDeco s
sh Theme
t XMonadFont
fs ((Window
w,Rectangle
_),(Just Window
dw,Just (Rectangle Position
_ Position
_ Dimension
wh Dimension
ht))) = do
  NamedWindow
nw  <- Window -> X NamedWindow
getName Window
w
  [Window]
ur  <- X [Window]
readUrgents
  Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  let focusColor :: Window -> b -> b -> b -> f b
focusColor Window
win b
ic b
ac b
uc = b -> (Window -> b) -> Maybe Window -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
ic (\Window
focusw -> case () of
                                                      ()
_ | Window
focusw Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
win -> b
ac
                                                        | Window
win Window -> [Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
ur -> b
uc
                                                        | Bool
otherwise     -> b
ic) (Maybe Window -> b)
-> (StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> Maybe Window)
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Maybe Window
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek
                                (StackSet String (Layout Window) Window ScreenId ScreenDetail -> b)
-> f (StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XState
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> f (StackSet String (Layout Window) Window ScreenId ScreenDetail)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset
  (String
bc,String
borderc,Dimension
borderw,String
tc) <-
    Window
-> (String, String, Dimension, String)
-> (String, String, Dimension, String)
-> (String, String, Dimension, String)
-> X (String, String, Dimension, String)
forall {f :: * -> *} {b}.
MonadState XState f =>
Window -> b -> b -> b -> f b
focusColor Window
w (Theme -> String
inactiveColor Theme
t, Theme -> String
inactiveBorderColor Theme
t, Theme -> Dimension
inactiveBorderWidth Theme
t, Theme -> String
inactiveTextColor Theme
t)
                 (Theme -> String
activeColor   Theme
t, Theme -> String
activeBorderColor   Theme
t, Theme -> Dimension
activeBorderWidth   Theme
t, Theme -> String
activeTextColor   Theme
t)
                 (Theme -> String
urgentColor   Theme
t, Theme -> String
urgentBorderColor   Theme
t, Theme -> Dimension
urgentBorderWidth   Theme
t, Theme -> String
urgentTextColor   Theme
t)
  let s :: String -> [String]
s = s -> String -> [String]
forall s. Shrinker s => s -> String -> [String]
shrinkIt s
sh
  String
name <- (String -> [String]) -> (String -> X Bool) -> String -> X String
shrinkWhile String -> [String]
s (\String
n -> do Int
size <- IO Int -> X Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Int -> X Int) -> IO Int -> X Int
forall a b. (a -> b) -> a -> b
$ Display -> XMonadFont -> String -> IO Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
fs String
n
                                  Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> X Bool) -> Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
wh Int -> Int -> Int
forall a. Num a => a -> a -> a
- Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dimension
ht Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
2)) (NamedWindow -> String
forall a. Show a => a -> String
show NamedWindow
nw)
  let als :: [Align]
als = Align
AlignCenter Align -> [Align] -> [Align]
forall a. a -> [a] -> [a]
: ((String, Align) -> Align) -> [(String, Align)] -> [Align]
forall a b. (a -> b) -> [a] -> [b]
map (String, Align) -> Align
forall a b. (a, b) -> b
snd (Theme -> [(String, Align)]
windowTitleAddons Theme
t)
      strs :: [String]
strs = String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String, Align) -> String) -> [(String, Align)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Align) -> String
forall a b. (a, b) -> a
fst (Theme -> [(String, Align)]
windowTitleAddons Theme
t)
      i_als :: [Placement]
i_als = (([[Bool]], Placement) -> Placement)
-> [([[Bool]], Placement)] -> [Placement]
forall a b. (a -> b) -> [a] -> [b]
map ([[Bool]], Placement) -> Placement
forall a b. (a, b) -> b
snd (Theme -> [([[Bool]], Placement)]
windowTitleIcons Theme
t)
      icons :: [[[Bool]]]
icons = (([[Bool]], Placement) -> [[Bool]])
-> [([[Bool]], Placement)] -> [[[Bool]]]
forall a b. (a -> b) -> [a] -> [b]
map ([[Bool]], Placement) -> [[Bool]]
forall a b. (a, b) -> a
fst (Theme -> [([[Bool]], Placement)]
windowTitleIcons Theme
t)
  Window
-> XMonadFont
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> [Placement]
-> [[[Bool]]]
-> X ()
paintTextAndIcons Window
dw XMonadFont
fs Dimension
wh Dimension
ht Dimension
borderw String
bc String
borderc String
tc String
bc [Align]
als [String]
strs [Placement]
i_als [[[Bool]]]
icons
updateDeco s
_ Theme
_ XMonadFont
_ (OrigWin
_,(Just Window
w,Maybe Rectangle
Nothing)) = Window -> X ()
hideWindow Window
w
updateDeco s
_ Theme
_ XMonadFont
_ (OrigWin, DecoWin)
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | True if the window is in the 'Stack'. The 'Window' comes second
-- to facilitate list processing, even though @w \`isInStack\` s@ won't
-- work...;)
isInStack :: Eq a => W.Stack a -> a -> Bool
isInStack :: forall a. Eq a => Stack a -> a -> Bool
isInStack Stack a
s = (a -> [a] -> Bool) -> [a] -> a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Stack a -> [a]
forall a. Stack a -> [a]
W.integrate Stack a
s)

-- | Given a 'Rectangle' and a list of 'Rectangle's is True if the
-- 'Rectangle' is not completely contained by any 'Rectangle' of the
-- list.
isVisible :: Rectangle -> [Rectangle] -> Bool
isVisible :: Rectangle -> [Rectangle] -> Bool
isVisible Rectangle
r = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> ([Rectangle] -> [Bool]) -> [Rectangle] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rectangle -> [Bool] -> [Bool]) -> [Bool] -> [Rectangle] -> [Bool]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Rectangle -> [Bool] -> [Bool]
f []
    where f :: Rectangle -> [Bool] -> [Bool]
f Rectangle
x [Bool]
xs = if Rectangle
r Rectangle -> Rectangle -> Bool
`isWithin` Rectangle
x then Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
xs else Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
xs

-- | The contrary of 'isVisible'.
isInvisible :: Rectangle -> [Rectangle] -> Bool
isInvisible :: Rectangle -> [Rectangle] -> Bool
isInvisible Rectangle
r = Bool -> Bool
not (Bool -> Bool) -> ([Rectangle] -> Bool) -> [Rectangle] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> [Rectangle] -> Bool
isVisible Rectangle
r

-- | True is the first 'Rectangle' is totally within the second
-- 'Rectangle'.
isWithin :: Rectangle -> Rectangle -> Bool
isWithin :: Rectangle -> Rectangle -> Bool
isWithin (Rectangle Position
x Position
y Dimension
w Dimension
h) (Rectangle Position
rx Position
ry Dimension
rw Dimension
rh)
    | Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
rx, Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
rx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
rw
    , Position
y Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
ry, Position
y Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
ry Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
rh
    , 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
w Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
rx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
rw
    , Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
h Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
ry Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
rh = Bool
True
    | Bool
otherwise              = Bool
False

shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X String
shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X String
shrinkWhile String -> [String]
sh String -> X Bool
p String
x = [String] -> X String
sw ([String] -> X String) -> [String] -> X String
forall a b. (a -> b) -> a -> b
$ String -> [String]
sh String
x
    where sw :: [String] -> X String
sw [String
n] = String -> X String
forall (m :: * -> *) a. Monad m => a -> m a
return String
n
          sw [] = String -> X String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
          sw (String
n:[String]
ns) = do
                        Bool
cond <- String -> X Bool
p String
n
                        if Bool
cond
                          then [String] -> X String
sw [String]
ns
                          else String -> X String
forall (m :: * -> *) a. Monad m => a -> m a
return String
n

data CustomShrink = CustomShrink
instance Show CustomShrink where show :: CustomShrink -> String
show CustomShrink
_ = String
""
instance Read CustomShrink where readsPrec :: Int -> ReadS CustomShrink
readsPrec Int
_ String
s = [(CustomShrink
CustomShrink,String
s)]

class (Read s, Show s) => Shrinker s where
    shrinkIt :: s -> String -> [String]

data DefaultShrinker = DefaultShrinker
instance Show DefaultShrinker where show :: DefaultShrinker -> String
show DefaultShrinker
_ = String
""
instance Read DefaultShrinker where readsPrec :: Int -> ReadS DefaultShrinker
readsPrec Int
_ String
s = [(DefaultShrinker
DefaultShrinker,String
s)]
instance Shrinker DefaultShrinker where
    shrinkIt :: DefaultShrinker -> String -> [String]
shrinkIt DefaultShrinker
_ String
"" = [String
""]
    shrinkIt DefaultShrinker
s String
cs = String
cs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: DefaultShrinker -> String -> [String]
forall s. Shrinker s => s -> String -> [String]
shrinkIt DefaultShrinker
s (ShowS
forall a. [a] -> [a]
init String
cs)

shrinkText :: DefaultShrinker
shrinkText :: DefaultShrinker
shrinkText = DefaultShrinker
DefaultShrinker