----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.DecorationAddons
-- Description :  Various stuff that can be added to the decoration.
-- Copyright   :  (c) Jan Vornberger 2009
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
-- Stability   :  unstable
-- Portability :  not portable
--
-- Various stuff that can be added to the decoration. Most of it
-- is intended to be used by other modules. See
-- "XMonad.Layout.ButtonDecoration" for a module that makes use of this.
--
-----------------------------------------------------------------------------

module XMonad.Layout.DecorationAddons (
                                    titleBarButtonHandler
                                   ,defaultThemeWithButtons
                                   ,handleScreenCrossing
                                   ) where

import XMonad
import qualified XMonad.StackSet as W
import XMonad.Layout.Decoration
import XMonad.Actions.WindowMenu
import XMonad.Actions.Minimize
import XMonad.Layout.Maximize
import XMonad.Hooks.ManageDocks
import XMonad.Util.Font
import XMonad.Util.PositionStore

import XMonad.Prelude
import qualified Data.Set as S

minimizeButtonOffset :: Int
minimizeButtonOffset :: Int
minimizeButtonOffset = Int
48

maximizeButtonOffset :: Int
maximizeButtonOffset :: Int
maximizeButtonOffset = Int
25

closeButtonOffset :: Int
closeButtonOffset :: Int
closeButtonOffset = Int
10

buttonSize :: Int
buttonSize :: Int
buttonSize = Int
10

-- | A function intended to be plugged into the 'decorationCatchClicksHook' of a decoration.
-- It will intercept clicks on the buttons of the decoration and invoke the associated action.
-- To actually see the buttons, you will need to use a theme that includes them.
-- See 'defaultThemeWithButtons' below.
titleBarButtonHandler :: Window -> Int -> Int -> X Bool
titleBarButtonHandler :: Window -> Int -> Int -> X Bool
titleBarButtonHandler Window
mainw Int
distFromLeft Int
distFromRight = do
    let action :: X Bool
action
          | Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
distFromLeft Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
buttonSize = Window -> X ()
focus Window
mainw X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
windowMenu X () -> X Bool -> X Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          | Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
distFromRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
closeButtonOffset Bool -> Bool -> Bool
&&
            Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
distFromRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
closeButtonOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
buttonSize = Window -> X ()
focus Window
mainw X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
kill X () -> X Bool -> X Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          | Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
distFromRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maximizeButtonOffset Bool -> Bool -> Bool
&&
            Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
distFromRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maximizeButtonOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
buttonSize) = Window -> X ()
focus Window
mainw X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MaximizeRestore -> X ()
forall a. Message a => a -> X ()
sendMessage (Window -> MaximizeRestore
maximizeRestore Window
mainw) X () -> X Bool -> X Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          | Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
distFromRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minimizeButtonOffset Bool -> Bool -> Bool
&&
            Int -> Int
forall a b. (Integral a, Num b) => a -> b
fi Int
distFromRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
minimizeButtonOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
buttonSize = Window -> X ()
focus Window
mainw X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Window -> X ()
minimizeWindow Window
mainw X () -> X Bool -> X Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          | Bool
otherwise = Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    X Bool
action

-- | Intended to be used together with 'titleBarButtonHandler'. See above.
defaultThemeWithButtons :: Theme
defaultThemeWithButtons :: Theme
defaultThemeWithButtons = Theme
forall a. Default a => a
def {
                            windowTitleAddons :: [(String, Align)]
windowTitleAddons = [ (String
" (M)", Align
AlignLeft)
                                                , (String
"_"   , Int -> Align
AlignRightOffset Int
minimizeButtonOffset)
                                                , (String
"[]"  , Int -> Align
AlignRightOffset Int
maximizeButtonOffset)
                                                , (String
"X"   , Int -> Align
AlignRightOffset Int
closeButtonOffset)
                                                ]
                            }

-- | A function intended to be plugged into the 'decorationAfterDraggingHook' of a decoration.
-- It will check if the window has been dragged onto another screen and shift it there.
-- The PositionStore is also updated accordingly, as this is designed to be used together
-- with "XMonad.Layout.PositionStoreFloat".
handleScreenCrossing :: Window -> Window -> X Bool
handleScreenCrossing :: Window -> Window -> X Bool
handleScreenCrossing Window
w Window
decoWin = (Display -> X Bool) -> X Bool
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Bool) -> X Bool) -> (Display -> X Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    Window
root <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    (Bool
_, Window
_, Window
_, CInt
px, CInt
py, CInt
_, CInt
_, Modifier
_) <- IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
 -> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier))
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
queryPointer Display
d Window
root
    WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    Screen String (Layout Window) Window ScreenId ScreenDetail
sc <- Screen String (Layout Window) Window ScreenId ScreenDetail
-> Maybe
     (Screen String (Layout Window) Window ScreenId ScreenDetail)
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall a. a -> Maybe a -> a
fromMaybe (WindowSet
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws) (Maybe (Screen String (Layout Window) Window ScreenId ScreenDetail)
 -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> X (Maybe
        (Screen String (Layout Window) Window ScreenId ScreenDetail))
-> X (Screen String (Layout Window) Window ScreenId ScreenDetail)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> Position
-> X (Maybe
        (Screen String (Layout Window) Window ScreenId ScreenDetail))
pointScreen (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
px) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
py)
    Maybe String
maybeWksp <- ScreenId -> X (Maybe String)
screenWorkspace (ScreenId -> X (Maybe String)) -> ScreenId -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ Screen String (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen Screen String (Layout Window) Window ScreenId ScreenDetail
sc
    let targetWksp :: Maybe String
targetWksp = Maybe String
maybeWksp Maybe String -> (String -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
wksp ->
                        Window -> WindowSet -> Maybe String
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Maybe i
W.findTag Window
w WindowSet
ws Maybe String -> (String -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
currentWksp ->
                        if String
currentWksp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
wksp
                            then String -> Maybe String
forall a. a -> Maybe a
Just String
wksp
                            else Maybe String
forall a. Maybe a
Nothing
    case Maybe String
targetWksp of
        Just String
wksp -> do
                        -- find out window under cursor on target workspace
                        -- apparently we have to switch to the workspace first
                        -- to make this work, which unforunately introduces some flicker
                        (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws' -> String -> WindowSet -> WindowSet
forall s i l a sd.
(Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.view String
wksp WindowSet
ws'
                        (Bool
_, Window
_, Window
selWin, CInt
_, CInt
_, CInt
_, CInt
_, Modifier
_) <- IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
 -> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier))
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
queryPointer Display
d Window
root

                        -- adjust PositionStore
                        let oldScreenRect :: Rectangle
oldScreenRect = ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (Screen String (Layout Window) Window ScreenId ScreenDetail
    -> ScreenDetail)
-> Screen String (Layout Window) Window ScreenId ScreenDetail
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> Rectangle)
-> Screen String (Layout Window) Window ScreenId ScreenDetail
-> Rectangle
forall a b. (a -> b) -> a -> b
$ WindowSet
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws
                            newScreenRect :: Rectangle
newScreenRect = ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (Screen String (Layout Window) Window ScreenId ScreenDetail
    -> ScreenDetail)
-> Screen String (Layout Window) Window ScreenId ScreenDetail
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> Rectangle)
-> Screen String (Layout Window) Window ScreenId ScreenDetail
-> Rectangle
forall a b. (a -> b) -> a -> b
$ Screen String (Layout Window) Window ScreenId ScreenDetail
sc
                        {-- somewhat ugly hack to get proper ScreenRect,
                            creates unwanted inter-dependencies
                            TODO: get ScreenRects in a proper way --}
                        Rectangle
oldScreenRect' <- ((Rectangle -> Rectangle) -> Rectangle)
-> X (Rectangle -> Rectangle) -> X Rectangle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Rectangle -> Rectangle) -> Rectangle -> Rectangle
forall a b. (a -> b) -> a -> b
$ Rectangle
oldScreenRect) (Set Direction2D -> X (Rectangle -> Rectangle)
calcGap (Set Direction2D -> X (Rectangle -> Rectangle))
-> Set Direction2D -> X (Rectangle -> Rectangle)
forall a b. (a -> b) -> a -> b
$ [Direction2D] -> Set Direction2D
forall a. Ord a => [a] -> Set a
S.fromList [Direction2D
forall a. Bounded a => a
minBound .. Direction2D
forall a. Bounded a => a
maxBound])
                        Rectangle
newScreenRect' <- ((Rectangle -> Rectangle) -> Rectangle)
-> X (Rectangle -> Rectangle) -> X Rectangle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Rectangle -> Rectangle) -> Rectangle -> Rectangle
forall a b. (a -> b) -> a -> b
$ Rectangle
newScreenRect) (Set Direction2D -> X (Rectangle -> Rectangle)
calcGap (Set Direction2D -> X (Rectangle -> Rectangle))
-> Set Direction2D -> X (Rectangle -> Rectangle)
forall a b. (a -> b) -> a -> b
$ [Direction2D] -> Set Direction2D
forall a. Ord a => [a] -> Set a
S.fromList [Direction2D
forall a. Bounded a => a
minBound .. Direction2D
forall a. Bounded a => a
maxBound])
                        WindowAttributes
wa <- IO WindowAttributes -> X WindowAttributes
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WindowAttributes -> X WindowAttributes)
-> IO WindowAttributes -> X WindowAttributes
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO WindowAttributes
getWindowAttributes Display
d Window
decoWin
                        (PositionStore -> PositionStore) -> X ()
modifyPosStore (\PositionStore
ps ->
                            PositionStore
-> Window
-> Position
-> Position
-> Rectangle
-> Rectangle
-> PositionStore
posStoreMove PositionStore
ps Window
w (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
wa)
                                Rectangle
oldScreenRect' Rectangle
newScreenRect')

                        -- set focus correctly so the window will be inserted
                        -- at the correct position on the target workspace
                        -- and then shift the window
                        (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws' -> String -> Window -> WindowSet -> WindowSet
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> a -> StackSet i l a s sd -> StackSet i l a s sd
W.shiftWin String
wksp Window
w (WindowSet -> WindowSet)
-> (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> WindowSet -> WindowSet
forall s a i l sd.
(Eq s, Eq a, Eq i) =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.focusWindow Window
selWin (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ WindowSet
ws'

                        -- return True to signal that screen crossing has taken place
                        Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe String
Nothing -> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False