{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards         #-}
{-# LANGUAGE TupleSections         #-}
-----------------------------------------------------------------------------
-- |
-- 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 = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (forall (m :: * -> *) a. m a -> Invisible m a
I 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
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]
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 { 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
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)
ReadS [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 = 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 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
dh) Dimension
w (Dimension
h forall a. Num a => a -> a -> a
- Dimension
dh)

    -- | The decoration event hook
    decorationEventHook :: ds a -> DecorationState -> Event -> X ()
    decorationEventHook = 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
_ = 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 forall a. Eq a => Stack a -> a -> Bool
isInStack Stack a
s a
w Bool -> Bool -> Bool
&& (Dimension
ht forall a. Ord a => a -> a -> Bool
< Dimension
ht')
                                                             then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x Position
y Dimension
wh Dimension
ht
                                                             else 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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)
ReadS [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
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
        forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing) s
sh Theme
t ds Window
ds)
    redoLayout Decoration ds s Window
_                                 Rectangle
_ Maybe (Stack Window)
Nothing [OrigWin]
_  = forall (m :: * -> *) a. Monad m => a -> m a
return ([], 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 = 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 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) = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. Eq a => ([a], [a]) -> ([a], [a])
diff (forall {b} {b} {b}. [((b, b), b)] -> [b]
get_ws [(OrigWin, DecoWin)]
dwrs) [Window]
ws
                                    toDel :: [(OrigWin, DecoWin)]
toDel = 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 = forall {t :: * -> *} {b} {b}.
(Foldable t, Eq b) =>
t b -> [(b, b)] -> [(b, b)]
toadd [Window]
a [OrigWin]
wrs
                                [DecoWin] -> X ()
deleteDecos (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(OrigWin, DecoWin)]
toDel)
                                let ndwrs :: [(OrigWin, (Maybe a, Maybe a))]
ndwrs = forall a b. (a -> b) -> [a] -> [b]
map (, (forall a. Maybe a
Nothing,forall a. Maybe a
Nothing)) [OrigWin]
toAdd
                                [(OrigWin, DecoWin)]
ndecos <- forall {b} {b}.
[((Window, b), (Maybe Window, b))]
-> [OrigWin] -> X [(OrigWin, DecoWin)]
resync (forall {a} {a}. [(OrigWin, (Maybe a, Maybe a))]
ndwrs forall a. [a] -> [a] -> [a]
++ 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        = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [OrigWin]
wrs
          get_w :: ((c, b), b) -> c
get_w     = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
          get_ws :: [((b, b), b)] -> [b]
get_ws    = forall a b. (a -> b) -> [a] -> [b]
map forall {c} {b} {b}. ((c, b), b) -> c
get_w
          del_dwrs :: [Window] -> [((Window, b), b)] -> [((Window, b), b)]
del_dwrs  = forall b c a. (b -> c) -> (c -> [a] -> Bool) -> [a] -> [b] -> [b]
listFromList forall {c} {b} {b}. ((c, b), b) -> c
get_w forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem
          find_dw :: Int -> [(a, (c, b))] -> c
find_dw Int
i = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> Int -> a
(!!) Int
i
          todel :: t b -> [((b, b), b)] -> [((b, b), b)]
todel   t b
d = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem t b
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {c} {b} {b}. ((c, b), b) -> c
get_w)
          toadd :: t b -> [(b, b)] -> [(b, b)]
toadd   t b
a = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem t b
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
                                                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Window
dw, forall a. a -> Maybe a
Just Rectangle
dr)
                            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))]
_         [] = 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 forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` forall {b} {b} {b}. [((b, b), b)] -> [b]
get_ws [((Window, b), (Maybe Window, b))]
d of
                                  Just Int
i  -> do Maybe Rectangle
dr   <- 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 (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
                                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Window
w,Rectangle
r),DecoWin
dwr) 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 :: [b] -> [(a, b)] -> [(a, b)]
remove_stacked [b]
rs ((a
w,b
r):[(a, b)]
xs)
              | b
r forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [b]
rs   = [b] -> [(a, b)] -> [(a, b)]
remove_stacked [b]
rs [(a, b)]
xs
              | Bool
otherwise     = (a
w,b
r) forall a. a -> [a] -> [a]
: [b] -> [(a, b)] -> [(a, b)]
remove_stacked (b
rforall a. a -> [a] -> [a]
:[b]
rs) [(a, b)]
xs
          remove_stacked [b]
_ [] = []

          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)forall a. a -> [a] -> [a]
:(a
w, forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> Rectangle -> Rectangle -> Rectangle
shrink ds Window
ds Rectangle
dr Rectangle
r)forall a. a -> [a] -> [a]
:[(a, Rectangle)]
xs
          insert_dwr ((a, Rectangle)
x    ,(     Maybe a
_ ,     Maybe Rectangle
_ )) [(a, Rectangle)]
xs = (a, Rectangle)
xforall a. a -> [a] -> [a]
:[(a, Rectangle)]
xs

          dwrs_to_wrs :: [((a, Rectangle), (Maybe a, Maybe Rectangle))] -> [(a, Rectangle)]
dwrs_to_wrs    = forall {b} {a}. Eq b => [b] -> [(a, b)] -> [(a, b)]
remove_stacked [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(OrigWin, DecoWin)]
ndwrs)
                              forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> [(OrigWin, DecoWin)] -> X ()
updateDecos s
sh Theme
t (DecorationState -> XMonadFont
font DecorationState
s) [(OrigWin, DecoWin)]
ndwrs
                              forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}.
[((a, Rectangle), (Maybe a, Maybe Rectangle))] -> [(a, Rectangle)]
dwrs_to_wrs [(OrigWin, DecoWin)]
ndwrs, forall a. a -> Maybe a
Just (forall (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (forall (m :: * -> *) a. m a -> Invisible m a
I (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 <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m                = do forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> DecorationState -> Event -> X ()
decorationEventHook ds Window
ds DecorationState
s Event
e
                                                      forall s.
Shrinker s =>
s -> Theme -> DecorationState -> Event -> X ()
handleEvent s
sh Theme
t DecorationState
s Event
e
                                                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        | Just LayoutMessages
Hide             <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do [DecoWin] -> X ()
hideDecos (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(OrigWin, DecoWin)]
dwrs)
                                                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        | Just (SetTheme Theme
nt)    <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do DecorationState -> X ()
releaseResources DecorationState
s
                                                      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 (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing) s
sh Theme
nt ds Window
ds
        | Just LayoutMessages
ReleaseResources <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do DecorationState -> X ()
releaseResources DecorationState
s
                                                      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 (ds :: * -> *) s a.
Invisible Maybe DecorationState
-> s -> Theme -> ds a -> Decoration ds s a
Decoration (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing) s
sh Theme
t  ds Window
ds
    handleMess Decoration ds s Window
_ SomeMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    modifierDescription :: Decoration ds s Window -> String
modifierDescription (Decoration Invisible Maybe DecorationState
_ s
_ Theme
_ ds Window
ds) = 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 forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(OrigWin, DecoWin)]
dwrs      = forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
updateDeco s
sh Theme
t XMonadFont
fs ([(OrigWin, DecoWin)]
dwrs forall a. [a] -> Int -> a
!! Int
i)
    | 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 (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(OrigWin, DecoWin)]
dwrs = forall s.
Shrinker s =>
s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X ()
updateDeco s
sh Theme
t XMonadFont
fs ([(OrigWin, DecoWin)]
dwrs forall a. [a] -> Int -> a
!! Int
i)
handleEvent s
_ Theme
_ DecorationState
_ Event
_ = 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 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
_ = forall a. HasCallStack => Maybe a -> a
fromJust Maybe Rectangle
decoRectM
            distFromLeft :: CInt
distFromLeft = CInt
ex forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi Position
dx
            distFromRight :: CInt
distFromRight = forall a b. (Integral a, Num b) => a -> b
fi Dimension
dwh forall a. Num a => a -> a -> a
- (CInt
ex forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi Position
dx)
        Bool
dealtWith <- forall (ds :: * -> *) a.
DecorationStyle ds a =>
ds a -> Window -> Int -> Int -> X Bool
decorationCatchClicksHook ds a
ds Window
mainw (forall a b. (Integral a, Num b) => a -> b
fi CInt
distFromLeft) (forall a b. (Integral a, Num b) => a -> b
fi CInt
distFromRight)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dealtWith forall a b. (a -> b) -> a -> b
$
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
x Position
y -> Window -> X ()
focus Window
mainw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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)
                        (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
_ = 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 forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fi CInt
ex forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_x Rectangle
r))
                         (Position
y forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fi CInt
ey forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_y Rectangle
r))
                         (Rectangle -> Dimension
rect_width  Rectangle
r)
                         (Rectangle -> Dimension
rect_height Rectangle
r)
    forall a. Message a => a -> X ()
sendMessage forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Window
dw = 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
_ [] = 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 <- 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd 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 <- 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 <- 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
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Window
w,Rectangle
r), (forall a. a -> Maybe a
Just Window
dw, forall a. a -> Maybe a
Just Rectangle
dr)) forall a. a -> [a] -> [a]
: [(OrigWin, DecoWin)]
dwrs
    Maybe Rectangle
Nothing -> do [(OrigWin, DecoWin)]
dwrs <- 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
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Window
w,Rectangle
r), (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)) forall a. a -> [a] -> [a]
: [(OrigWin, DecoWin)]
dwrs
createDecos Theme
_ ds Window
_ Rectangle
_ Stack Window
_ [OrigWin]
_ [] = 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 = forall a. a -> Maybe a
Just (Window
exposureMask 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 <- 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 (f :: * -> *) a. Applicative f => a -> f a
pure Window
w

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

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

deleteDecos :: [DecoWin] -> X ()
deleteDecos :: [DecoWin] -> X ()
deleteDecos = [Window] -> X ()
deleteWindows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a b. (a -> b) -> a -> b
$ 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
  -- xmonad-contrib #809
  -- qutebrowser will happily shovel a 389K multiline string into @_NET_WM_NAME@
  -- and the 'defaultShrinker' (a) doesn't handle multiline strings well (b) is
  -- quadratic due to using 'init'
  String
nw  <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> [a] -> [a]
take Int
2048 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (Window -> X NamedWindow
getName Window
w)
  [Window]
ur  <- X [Window]
readUrgents
  Display
dpy <- 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
ic (\Window
focusw -> case () of
                                                      ()
_ | Window
focusw forall a. Eq a => a -> a -> Bool
== Window
win -> b
ac
                                                        | Window
win forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
ur -> b
uc
                                                        | Bool
otherwise     -> b
ic) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek
                                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <-
    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 = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
fs String
n
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
size forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
wh forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dimension
ht forall a. Integral a => a -> a -> a
`div` Dimension
2)) String
nw
  let als :: [Align]
als = Align
AlignCenter forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (Theme -> [(String, Align)]
windowTitleAddons Theme
t)
      strs :: [String]
strs = String
name forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (Theme -> [(String, Align)]
windowTitleAddons Theme
t)
      i_als :: [Placement]
i_als = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (Theme -> [([[Bool]], Placement)]
windowTitleIcons Theme
t)
      icons :: [[[Bool]]]
icons = forall a b. (a -> b) -> [a] -> [b]
map 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)
_ = 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (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 = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. a -> [a] -> [a]
: [Bool]
xs else Bool
True 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 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 forall a. Ord a => a -> a -> Bool
>= Position
rx, Position
x forall a. Ord a => a -> a -> Bool
<= Position
rx forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
rw
    , Position
y forall a. Ord a => a -> a -> Bool
>= Position
ry, Position
y forall a. Ord a => a -> a -> Bool
<= Position
ry forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
rh
    , Position
x forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
w forall a. Ord a => a -> a -> Bool
<= Position
rx forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
rw
    , Position
y forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
h forall a. Ord a => a -> a -> Bool
<= Position
ry forall a. Num a => a -> a -> a
+ 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 forall a b. (a -> b) -> a -> b
$ String -> [String]
sh String
x
    where sw :: [String] -> X String
sw [String
n] = forall (m :: * -> *) a. Monad m => a -> m a
return String
n
          sw [] = 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 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 forall a. a -> [a] -> [a]
: forall s. Shrinker s => s -> String -> [String]
shrinkIt DefaultShrinker
s (forall a. [a] -> [a]
init String
cs)

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