{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- --------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Operations
-- Copyright   :  (c) Spencer Janssen 2007
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  dons@cse.unsw.edu.au
-- Stability   :  unstable
-- Portability :  not portable, mtl, posix
--
-- Operations. A module for functions that don't cleanly fit anywhere else.
--
-----------------------------------------------------------------------------

module XMonad.Operations (
    -- * Manage One Window
    manage, unmanage, killWindow, kill, isClient,
    setInitialProperties, setWMState, setWindowBorderWithFallback,
    hide, reveal, tileWindow,
    setTopFocus, focus, isFixedSizeOrTransient,

    -- * Manage Windows
    windows, refresh, rescreen, modifyWindowSet, windowBracket, windowBracket_, clearEvents, getCleanedScreenInfo,
    withFocused, withUnfocused,

    -- * Keyboard and Mouse
    cleanMask, extraModifiers,
    mouseDrag, mouseMoveWindow, mouseResizeWindow,
    setButtonGrab, setFocusX, cacheNumlockMask, mkGrabs, unGrab,

    -- * Messages
    sendMessage, broadcastMessage, sendMessageWithNoRefresh,
    sendRestart, sendReplace,

    -- * Save and Restore State
    StateFile (..), writeStateToFile, readStateFile, restart,

    -- * Floating Layer
    float, floatLocation,

    -- * Window Size Hints
    D, mkAdjust, applySizeHints, applySizeHints', applySizeHintsContents,
    applyAspectHint, applyResizeIncHint, applyMaxSizeHint,

    -- * Rectangles
    containedIn, nubScreens, pointWithin, scaleRationalRect,

    -- * Other Utilities
    initColor, pointScreen, screenWorkspace,
    setLayout, updateLayout,
    ) where

import XMonad.Core
import XMonad.Layout (Full(..))
import qualified XMonad.StackSet as W

import Data.Maybe
import Data.Monoid          (Endo(..),Any(..))
import Data.List            (nub, (\\), find)
import Data.Bits            ((.|.), (.&.), complement, setBit, testBit)
import Data.Function        (on)
import Data.Ratio
import qualified Data.Map as M
import qualified Data.Set as S

import Control.Arrow (second)
import Control.Monad.Fix (fix)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad (forM, forM_, guard, join, unless, void, when)
import qualified Control.Exception as C

import System.IO
import System.Directory
import System.Posix.Process (executeFile)
import Graphics.X11.Xlib
import Graphics.X11.Xinerama (getScreenInfo)
import Graphics.X11.Xlib.Extras

-- ---------------------------------------------------------------------
-- Window manager operations

-- | Detect whether a window has fixed size or is transient. This check
-- can be used to determine whether the window should be floating or not
--
isFixedSizeOrTransient :: Display -> Window -> X Bool
isFixedSizeOrTransient :: Display -> Pixel -> X Bool
isFixedSizeOrTransient Display
d Pixel
w = do
    SizeHints
sh <- IO SizeHints -> X SizeHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SizeHints -> X SizeHints) -> IO SizeHints -> X SizeHints
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO SizeHints
getWMNormalHints Display
d Pixel
w
    let isFixedSize :: Bool
isFixedSize = Maybe (Dimension, Dimension) -> Bool
forall a. Maybe a -> Bool
isJust (SizeHints -> Maybe (Dimension, Dimension)
sh_min_size SizeHints
sh) Bool -> Bool -> Bool
&& SizeHints -> Maybe (Dimension, Dimension)
sh_min_size SizeHints
sh Maybe (Dimension, Dimension)
-> Maybe (Dimension, Dimension) -> Bool
forall a. Eq a => a -> a -> Bool
== SizeHints -> Maybe (Dimension, Dimension)
sh_max_size SizeHints
sh
    Bool
isTransient <- Maybe Pixel -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Pixel -> Bool) -> X (Maybe Pixel) -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Pixel) -> X (Maybe Pixel)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> Pixel -> IO (Maybe Pixel)
getTransientForHint Display
d Pixel
w)
    Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isFixedSize Bool -> Bool -> Bool
|| Bool
isTransient)

-- |
-- Add a new window to be managed in the current workspace.
-- Bring it into focus.
--
-- Whether the window is already managed, or not, it is mapped, has its
-- border set, and its event mask set.
--
manage :: Window -> X ()
manage :: Pixel -> X ()
manage Pixel
w = X Bool -> X () -> X ()
whenX (Bool -> Bool
not (Bool -> Bool) -> X Bool -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pixel -> X Bool
isClient Pixel
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do

    Bool
shouldFloat <- Display -> Pixel -> X Bool
isFixedSizeOrTransient Display
d Pixel
w

    RationalRect
rr <- (ScreenId, RationalRect) -> RationalRect
forall a b. (a, b) -> b
snd ((ScreenId, RationalRect) -> RationalRect)
-> X (ScreenId, RationalRect) -> X RationalRect
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Pixel -> X (ScreenId, RationalRect)
floatLocation Pixel
w
    -- ensure that float windows don't go over the edge of the screen
    let adjust :: RationalRect -> RationalRect
adjust (W.RationalRect Rational
x Rational
y Rational
wid Rational
h) | Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
wid Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
1 Bool -> Bool -> Bool
|| Rational
y Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
h Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
1 Bool -> Bool -> Bool
|| Rational
x Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0 Bool -> Bool -> Bool
|| Rational
y Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0
                                              = Rational -> Rational -> Rational -> Rational -> RationalRect
W.RationalRect (Rational
0.5 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
widRational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
2) (Rational
0.5 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
hRational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
2) Rational
wid Rational
h
        adjust RationalRect
r = RationalRect
r

        f :: StackSet i l Pixel s sd -> StackSet i l Pixel s sd
f StackSet i l Pixel s sd
ws | Bool
shouldFloat = Pixel
-> RationalRect
-> StackSet i l Pixel s sd
-> StackSet i l Pixel s sd
forall a i l s sd.
Ord a =>
a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd
W.float Pixel
w (RationalRect -> RationalRect
adjust RationalRect
rr) (StackSet i l Pixel s sd -> StackSet i l Pixel s sd)
-> (StackSet i l Pixel s sd -> StackSet i l Pixel s sd)
-> StackSet i l Pixel s sd
-> StackSet i l Pixel s sd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel -> StackSet i l Pixel s sd -> StackSet i l Pixel s sd
forall a i l s sd.
Eq a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.insertUp Pixel
w (StackSet i l Pixel s sd -> StackSet i l Pixel s sd)
-> (StackSet i l Pixel s sd -> StackSet i l Pixel s sd)
-> StackSet i l Pixel s sd
-> StackSet i l Pixel s sd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> StackSet i l Pixel s sd -> StackSet i l Pixel s sd
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 i
i (StackSet i l Pixel s sd -> StackSet i l Pixel s sd)
-> StackSet i l Pixel s sd -> StackSet i l Pixel s sd
forall a b. (a -> b) -> a -> b
$ StackSet i l Pixel s sd
ws
             | Bool
otherwise   = Pixel -> StackSet i l Pixel s sd -> StackSet i l Pixel s sd
forall a i l s sd.
Eq a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.insertUp Pixel
w StackSet i l Pixel s sd
ws
            where i :: i
i = Workspace i l Pixel -> i
forall i l a. Workspace i l a -> i
W.tag (Workspace i l Pixel -> i) -> Workspace i l Pixel -> i
forall a b. (a -> b) -> a -> b
$ Screen i l Pixel s sd -> Workspace i l Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen i l Pixel s sd -> Workspace i l Pixel)
-> Screen i l Pixel s sd -> Workspace i l Pixel
forall a b. (a -> b) -> a -> b
$ StackSet i l Pixel s sd -> Screen i l Pixel s sd
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current StackSet i l Pixel s sd
ws

    ManageHook
mh <- (XConf -> ManageHook) -> X ManageHook
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> ManageHook
forall (l :: * -> *). XConfig l -> ManageHook
manageHook (XConfig Layout -> ManageHook)
-> (XConf -> XConfig Layout) -> XConf -> ManageHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
    WindowSet -> WindowSet
g <- Endo WindowSet -> WindowSet -> WindowSet
forall a. Endo a -> a -> a
appEndo (Endo WindowSet -> WindowSet -> WindowSet)
-> X (Endo WindowSet) -> X (WindowSet -> WindowSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Endo WindowSet -> X (Endo WindowSet) -> X (Endo WindowSet)
forall a. a -> X a -> X a
userCodeDef ((WindowSet -> WindowSet) -> Endo WindowSet
forall a. (a -> a) -> Endo a
Endo WindowSet -> WindowSet
forall a. a -> a
id) (ManageHook -> Pixel -> X (Endo WindowSet)
forall a. Query a -> Pixel -> X a
runQuery ManageHook
mh Pixel
w)
    (WindowSet -> WindowSet) -> X ()
windows (WindowSet -> WindowSet
g (WindowSet -> WindowSet)
-> (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> WindowSet
forall {s} {i} {l} {sd}.
(Eq s, Eq i) =>
StackSet i l Pixel s sd -> StackSet i l Pixel s sd
f)

-- | A window no longer exists; remove it from the window
-- list, on whatever workspace it is.
--
unmanage :: Window -> X ()
unmanage :: Pixel -> X ()
unmanage = (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (Pixel -> WindowSet -> WindowSet) -> Pixel -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel -> WindowSet -> WindowSet
forall a i l s sd.
Ord a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.delete

-- | Kill the specified window. If we do kill it, we'll get a
-- delete notify back from X.
--
-- There are two ways to delete a window. Either just kill it, or if it
-- supports the delete protocol, send a delete event (e.g. firefox)
--
killWindow :: Window -> X ()
killWindow :: Pixel -> X ()
killWindow Pixel
w = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    Pixel
wmdelt <- X Pixel
atom_WM_DELETE_WINDOW  ;  Pixel
wmprot <- X Pixel
atom_WM_PROTOCOLS

    [Pixel]
protocols <- IO [Pixel] -> X [Pixel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Pixel] -> X [Pixel]) -> IO [Pixel] -> X [Pixel]
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO [Pixel]
getWMProtocols Display
d Pixel
w
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ if Pixel
wmdelt Pixel -> [Pixel] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pixel]
protocols
        then (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
ev -> do
                XEventPtr -> Dimension -> IO ()
setEventType XEventPtr
ev Dimension
clientMessage
                XEventPtr -> Pixel -> Pixel -> CInt -> Pixel -> Pixel -> IO ()
setClientMessageEvent XEventPtr
ev Pixel
w Pixel
wmprot CInt
32 Pixel
wmdelt Pixel
currentTime
                Display -> Pixel -> Bool -> Pixel -> XEventPtr -> IO ()
sendEvent Display
d Pixel
w Bool
False Pixel
noEventMask XEventPtr
ev
        else IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Display -> Pixel -> IO CInt
killClient Display
d Pixel
w)

-- | Kill the currently focused client.
kill :: X ()
kill :: X ()
kill = (Pixel -> X ()) -> X ()
withFocused Pixel -> X ()
killWindow

-- ---------------------------------------------------------------------
-- Managing windows

-- | Modify the current window list with a pure function, and refresh
windows :: (WindowSet -> WindowSet) -> X ()
windows :: (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
f = do
    XState { windowset :: XState -> WindowSet
windowset = WindowSet
old } <- X XState
forall s (m :: * -> *). MonadState s m => m s
get
    let oldvisible :: [Pixel]
oldvisible = (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> [Pixel])
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [Pixel]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe (Stack Pixel) -> [Pixel]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Maybe (Stack Pixel) -> [Pixel])
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> Maybe (Stack Pixel))
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Pixel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace WorkspaceId (Layout Pixel) Pixel -> Maybe (Stack Pixel)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace WorkspaceId (Layout Pixel) Pixel -> Maybe (Stack Pixel))
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Maybe (Stack Pixel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) ([Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
 -> [Pixel])
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [Pixel]
forall a b. (a -> b) -> a -> b
$ WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
old Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: WindowSet
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible WindowSet
old
        newwindows :: [Pixel]
newwindows = WindowSet -> [Pixel]
forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
ws [Pixel] -> [Pixel] -> [Pixel]
forall a. Eq a => [a] -> [a] -> [a]
\\ WindowSet -> [Pixel]
forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
old
        ws :: WindowSet
ws = WindowSet -> WindowSet
f WindowSet
old
    XConf { display :: XConf -> Display
display = Display
d , normalBorder :: XConf -> Pixel
normalBorder = Pixel
nbc, focusedBorder :: XConf -> Pixel
focusedBorder = Pixel
fbc } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask

    (Pixel -> X ()) -> [Pixel] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Pixel -> X ()
setInitialProperties [Pixel]
newwindows

    Maybe Pixel -> (Pixel -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (WindowSet -> Maybe Pixel
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
old) ((Pixel -> X ()) -> X ()) -> (Pixel -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Pixel
otherw -> do
      WorkspaceId
nbs <- (XConf -> WorkspaceId) -> X WorkspaceId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> WorkspaceId
forall (l :: * -> *). XConfig l -> WorkspaceId
normalBorderColor (XConfig Layout -> WorkspaceId)
-> (XConf -> XConfig Layout) -> XConf -> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
      Display -> Pixel -> WorkspaceId -> Pixel -> X ()
setWindowBorderWithFallback Display
d Pixel
otherw WorkspaceId
nbs Pixel
nbc

    (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { windowset = ws })

    -- notify non visibility
    let tags_oldvisible :: [WorkspaceId]
tags_oldvisible = (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> WorkspaceId)
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId)
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) ([Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
 -> [WorkspaceId])
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
old Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: WindowSet
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible WindowSet
old
        gottenhidden :: [Workspace WorkspaceId (Layout Pixel) Pixel]
gottenhidden    = (Workspace WorkspaceId (Layout Pixel) Pixel -> Bool)
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a. (a -> Bool) -> [a] -> [a]
filter ((WorkspaceId -> [WorkspaceId] -> Bool)
-> [WorkspaceId] -> WorkspaceId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspaceId -> [WorkspaceId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [WorkspaceId]
tags_oldvisible (WorkspaceId -> Bool)
-> (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId)
-> Workspace WorkspaceId (Layout Pixel) Pixel
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag) ([Workspace WorkspaceId (Layout Pixel) Pixel]
 -> [Workspace WorkspaceId (Layout Pixel) Pixel])
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a b. (a -> b) -> a -> b
$ WindowSet -> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
W.hidden WindowSet
ws
    (Workspace WorkspaceId (Layout Pixel) Pixel -> X ())
-> [Workspace WorkspaceId (Layout Pixel) Pixel] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (LayoutMessages
-> Workspace WorkspaceId (Layout Pixel) Pixel -> X ()
forall a.
Message a =>
a -> Workspace WorkspaceId (Layout Pixel) Pixel -> X ()
sendMessageWithNoRefresh LayoutMessages
Hide) [Workspace WorkspaceId (Layout Pixel) Pixel]
gottenhidden

    -- for each workspace, layout the currently visible workspaces
    let allscreens :: [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
allscreens     = WindowSet
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.screens WindowSet
ws
        summed_visible :: [[Pixel]]
summed_visible = ([Pixel] -> [Pixel] -> [Pixel])
-> [Pixel] -> [[Pixel]] -> [[Pixel]]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl [Pixel] -> [Pixel] -> [Pixel]
forall a. [a] -> [a] -> [a]
(++) [] ([[Pixel]] -> [[Pixel]]) -> [[Pixel]] -> [[Pixel]]
forall a b. (a -> b) -> a -> b
$ (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> [Pixel])
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [[Pixel]]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (Stack Pixel) -> [Pixel]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Maybe (Stack Pixel) -> [Pixel])
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> Maybe (Stack Pixel))
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Pixel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace WorkspaceId (Layout Pixel) Pixel -> Maybe (Stack Pixel)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace WorkspaceId (Layout Pixel) Pixel -> Maybe (Stack Pixel))
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Maybe (Stack Pixel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
allscreens
    [(Pixel, Rectangle)]
rects <- ([[(Pixel, Rectangle)]] -> [(Pixel, Rectangle)])
-> X [[(Pixel, Rectangle)]] -> X [(Pixel, Rectangle)]
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Pixel, Rectangle)]] -> [(Pixel, Rectangle)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (X [[(Pixel, Rectangle)]] -> X [(Pixel, Rectangle)])
-> X [[(Pixel, Rectangle)]] -> X [(Pixel, Rectangle)]
forall a b. (a -> b) -> a -> b
$ [(Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail,
  [Pixel])]
-> ((Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail,
     [Pixel])
    -> X [(Pixel, Rectangle)])
-> X [[(Pixel, Rectangle)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [[Pixel]]
-> [(Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail,
     [Pixel])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
allscreens [[Pixel]]
summed_visible) (((Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail,
   [Pixel])
  -> X [(Pixel, Rectangle)])
 -> X [[(Pixel, Rectangle)]])
-> ((Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail,
     [Pixel])
    -> X [(Pixel, Rectangle)])
-> X [[(Pixel, Rectangle)]]
forall a b. (a -> b) -> a -> b
$ \ (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
w, [Pixel]
vis) -> do
        let wsp :: Workspace WorkspaceId (Layout Pixel) Pixel
wsp   = Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
w
            this :: WindowSet
this  = WorkspaceId -> 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 WorkspaceId
n WindowSet
ws
            n :: WorkspaceId
n     = Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag Workspace WorkspaceId (Layout Pixel) Pixel
wsp
            tiled :: Maybe (Stack Pixel)
tiled = (Workspace WorkspaceId (Layout Pixel) Pixel -> Maybe (Stack Pixel)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace WorkspaceId (Layout Pixel) Pixel -> Maybe (Stack Pixel))
-> (WindowSet -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> WindowSet
-> Maybe (Stack Pixel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> (WindowSet
    -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> WindowSet
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet -> Maybe (Stack Pixel))
-> WindowSet -> Maybe (Stack Pixel)
forall a b. (a -> b) -> a -> b
$ WindowSet
this)
                    Maybe (Stack Pixel)
-> (Stack Pixel -> Maybe (Stack Pixel)) -> Maybe (Stack Pixel)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pixel -> Bool) -> Stack Pixel -> Maybe (Stack Pixel)
forall a. (a -> Bool) -> Stack a -> Maybe (Stack a)
W.filter (Pixel -> Map Pixel RationalRect -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` WindowSet -> Map Pixel RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating WindowSet
ws)
                    Maybe (Stack Pixel)
-> (Stack Pixel -> Maybe (Stack Pixel)) -> Maybe (Stack Pixel)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pixel -> Bool) -> Stack Pixel -> Maybe (Stack Pixel)
forall a. (a -> Bool) -> Stack a -> Maybe (Stack a)
W.filter (Pixel -> [Pixel] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Pixel]
vis)
            viewrect :: Rectangle
viewrect = ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle) -> ScreenDetail -> Rectangle
forall a b. (a -> b) -> a -> b
$ Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
w

        -- just the tiled windows:
        -- now tile the windows on this workspace, modified by the gap
        ([(Pixel, Rectangle)]
rs, Maybe (Layout Pixel)
ml') <- Workspace WorkspaceId (Layout Pixel) Pixel
-> Rectangle -> X ([(Pixel, Rectangle)], Maybe (Layout Pixel))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace WorkspaceId (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace WorkspaceId (Layout Pixel) Pixel
wsp { W.stack = tiled } Rectangle
viewrect X ([(Pixel, Rectangle)], Maybe (Layout Pixel))
-> X ([(Pixel, Rectangle)], Maybe (Layout Pixel))
-> X ([(Pixel, Rectangle)], Maybe (Layout Pixel))
forall a. X a -> X a -> X a
`catchX`
                     Workspace WorkspaceId (Layout Pixel) Pixel
-> Rectangle -> X ([(Pixel, Rectangle)], Maybe (Layout Pixel))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace WorkspaceId (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace WorkspaceId (Layout Pixel) Pixel
wsp { W.stack = tiled, W.layout = Layout Full } Rectangle
viewrect
        WorkspaceId -> Maybe (Layout Pixel) -> X ()
updateLayout WorkspaceId
n Maybe (Layout Pixel)
ml'

        let m :: Map Pixel RationalRect
m   = WindowSet -> Map Pixel RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating WindowSet
ws
            flt :: [(Pixel, Rectangle)]
flt = [(Pixel
fw, Rectangle -> RationalRect -> Rectangle
scaleRationalRect Rectangle
viewrect RationalRect
r)
                    | Pixel
fw <- (Pixel -> Bool) -> [Pixel] -> [Pixel]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pixel -> Map Pixel RationalRect -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Pixel RationalRect
m) (WindowSet -> [Pixel]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index WindowSet
this)
                    , Pixel
fw Pixel -> [Pixel] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Pixel]
vis
                    , Just RationalRect
r <- [Pixel -> Map Pixel RationalRect -> Maybe RationalRect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Pixel
fw Map Pixel RationalRect
m]]
            vs :: [(Pixel, Rectangle)]
vs = [(Pixel, Rectangle)]
flt [(Pixel, Rectangle)]
-> [(Pixel, Rectangle)] -> [(Pixel, Rectangle)]
forall a. [a] -> [a] -> [a]
++ [(Pixel, Rectangle)]
rs

        IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> [Pixel] -> IO ()
restackWindows Display
d (((Pixel, Rectangle) -> Pixel) -> [(Pixel, Rectangle)] -> [Pixel]
forall a b. (a -> b) -> [a] -> [b]
map (Pixel, Rectangle) -> Pixel
forall a b. (a, b) -> a
fst [(Pixel, Rectangle)]
vs)
        -- return the visible windows for this workspace:
        [(Pixel, Rectangle)] -> X [(Pixel, Rectangle)]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pixel, Rectangle)]
vs

    let visible :: [Pixel]
visible = ((Pixel, Rectangle) -> Pixel) -> [(Pixel, Rectangle)] -> [Pixel]
forall a b. (a -> b) -> [a] -> [b]
map (Pixel, Rectangle) -> Pixel
forall a b. (a, b) -> a
fst [(Pixel, Rectangle)]
rects

    ((Pixel, Rectangle) -> X ()) -> [(Pixel, Rectangle)] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Pixel -> Rectangle -> X ()) -> (Pixel, Rectangle) -> X ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Pixel -> Rectangle -> X ()
tileWindow) [(Pixel, Rectangle)]
rects

    Maybe Pixel -> (Pixel -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (WindowSet -> Maybe Pixel
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
ws) ((Pixel -> X ()) -> X ()) -> (Pixel -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Pixel
w -> do
      WorkspaceId
fbs <- (XConf -> WorkspaceId) -> X WorkspaceId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> WorkspaceId
forall (l :: * -> *). XConfig l -> WorkspaceId
focusedBorderColor (XConfig Layout -> WorkspaceId)
-> (XConf -> XConfig Layout) -> XConf -> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
      Display -> Pixel -> WorkspaceId -> Pixel -> X ()
setWindowBorderWithFallback Display
d Pixel
w WorkspaceId
fbs Pixel
fbc

    (Pixel -> X ()) -> [Pixel] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Pixel -> X ()
reveal [Pixel]
visible
    X ()
setTopFocus

    -- hide every window that was potentially visible before, but is not
    -- given a position by a layout now.
    (Pixel -> X ()) -> [Pixel] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Pixel -> X ()
hide ([Pixel] -> [Pixel]
forall a. Eq a => [a] -> [a]
nub ([Pixel]
oldvisible [Pixel] -> [Pixel] -> [Pixel]
forall a. [a] -> [a] -> [a]
++ [Pixel]
newwindows) [Pixel] -> [Pixel] -> [Pixel]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Pixel]
visible)

    -- all windows that are no longer in the windowset are marked as
    -- withdrawn, it is important to do this after the above, otherwise 'hide'
    -- will overwrite withdrawnState with iconicState
    (Pixel -> X ()) -> [Pixel] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pixel -> Int -> X ()
`setWMState` Int
withdrawnState) (WindowSet -> [Pixel]
forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
old [Pixel] -> [Pixel] -> [Pixel]
forall a. Eq a => [a] -> [a] -> [a]
\\ WindowSet -> [Pixel]
forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
ws)

    Bool
isMouseFocused <- (XConf -> Bool) -> X Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Bool
mouseFocused
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isMouseFocused (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Pixel -> X ()
clearEvents Pixel
enterWindowMask
    (XConf -> X ()) -> X (X ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook (XConfig Layout -> X ())
-> (XConf -> XConfig Layout) -> XConf -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) X (X ()) -> (X () -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= () -> X () -> X ()
forall a. a -> X a -> X a
userCodeDef ()

-- | Modify the @WindowSet@ in state with no special handling.
modifyWindowSet :: (WindowSet -> WindowSet) -> X ()
modifyWindowSet :: (WindowSet -> WindowSet) -> X ()
modifyWindowSet WindowSet -> WindowSet
f = (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XState -> XState) -> X ()) -> (XState -> XState) -> X ()
forall a b. (a -> b) -> a -> b
$ \XState
xst -> XState
xst { windowset = f (windowset xst) }

-- | Perform an @X@ action and check its return value against a predicate p.
-- If p holds, unwind changes to the @WindowSet@ and replay them using @windows@.
windowBracket :: (a -> Bool) -> X a -> X a
windowBracket :: forall a. (a -> Bool) -> X a -> X a
windowBracket a -> Bool
p X a
action = (WindowSet -> X a) -> X a
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X a) -> X a) -> (WindowSet -> X a) -> X a
forall a b. (a -> b) -> a -> b
$ \WindowSet
old -> do
  a
a <- X a
action
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a -> Bool
p a
a) (X () -> X ())
-> ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
new -> do
    (WindowSet -> WindowSet) -> X ()
modifyWindowSet ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ WindowSet -> WindowSet -> WindowSet
forall a b. a -> b -> a
const WindowSet
old
    (WindowSet -> WindowSet) -> X ()
windows         ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ WindowSet -> WindowSet -> WindowSet
forall a b. a -> b -> a
const WindowSet
new
  a -> X a
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Perform an @X@ action. If it returns @Any True@, unwind the
-- changes to the @WindowSet@ and replay them using @windows@. This is
-- a version of @windowBracket@ that discards the return value and
-- handles an @X@ action that reports its need for refresh via @Any@.
windowBracket_ :: X Any -> X ()
windowBracket_ :: X Any -> X ()
windowBracket_ = X Any -> X ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (X Any -> X ()) -> (X Any -> X Any) -> X Any -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Any -> Bool) -> X Any -> X Any
forall a. (a -> Bool) -> X a -> X a
windowBracket Any -> Bool
getAny

-- | Produce the actual rectangle from a screen and a ratio on that screen.
scaleRationalRect :: Rectangle -> W.RationalRect -> Rectangle
scaleRationalRect :: Rectangle -> RationalRect -> Rectangle
scaleRationalRect (Rectangle Position
sx Position
sy Dimension
sw Dimension
sh) (W.RationalRect Rational
rx Rational
ry Rational
rw Rational
rh)
 = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
sx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Rational -> Position
forall {b} {a}. (Integral b, Real a) => a -> Rational -> b
scale Dimension
sw Rational
rx) (Position
sy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Rational -> Position
forall {b} {a}. (Integral b, Real a) => a -> Rational -> b
scale Dimension
sh Rational
ry) (Dimension -> Rational -> Dimension
forall {b} {a}. (Integral b, Real a) => a -> Rational -> b
scale Dimension
sw Rational
rw) (Dimension -> Rational -> Dimension
forall {b} {a}. (Integral b, Real a) => a -> Rational -> b
scale Dimension
sh Rational
rh)
 where scale :: a -> Rational -> b
scale a
s Rational
r = Rational -> b
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (a -> Rational
forall a. Real a => a -> Rational
toRational a
s Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
r)

-- | Set a window's WM_STATE property.
setWMState :: Window -> Int -> X ()
setWMState :: Pixel -> Int -> X ()
setWMState Pixel
w Int
v = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    Pixel
a <- X Pixel
atom_WM_STATE
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Pixel -> Pixel -> CInt -> [CLong] -> IO ()
changeProperty32 Display
dpy Pixel
w Pixel
a Pixel
a CInt
propModeReplace [Int -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v, Pixel -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel
none]

-- | Set the border color using the window's color map, if possible;
-- otherwise fall back to the color in @Pixel@.
setWindowBorderWithFallback :: Display -> Window -> String -> Pixel -> X ()
setWindowBorderWithFallback :: Display -> Pixel -> WorkspaceId -> Pixel -> X ()
setWindowBorderWithFallback Display
dpy Pixel
w WorkspaceId
color Pixel
basic = IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$
    (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle SomeException -> IO ()
fallback (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      WindowAttributes
wa <- Display -> Pixel -> IO WindowAttributes
getWindowAttributes Display
dpy Pixel
w
      Pixel
pixel <- Pixel -> Pixel
setPixelSolid (Pixel -> Pixel)
-> ((Color, Color) -> Pixel) -> (Color, Color) -> Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Pixel
color_pixel (Color -> Pixel)
-> ((Color, Color) -> Color) -> (Color, Color) -> Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color, Color) -> Color
forall a b. (a, b) -> a
fst ((Color, Color) -> Pixel) -> IO (Color, Color) -> IO Pixel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Pixel -> WorkspaceId -> IO (Color, Color)
allocNamedColor Display
dpy (WindowAttributes -> Pixel
wa_colormap WindowAttributes
wa) WorkspaceId
color
      Display -> Pixel -> Pixel -> IO ()
setWindowBorder Display
dpy Pixel
w Pixel
pixel
  where
    fallback :: C.SomeException -> IO ()
    fallback :: SomeException -> IO ()
fallback SomeException
_ = Display -> Pixel -> Pixel -> IO ()
setWindowBorder Display
dpy Pixel
w Pixel
basic

-- | Hide a window by unmapping it and setting Iconified.
hide :: Window -> X ()
hide :: Pixel -> X ()
hide Pixel
w = X Bool -> X () -> X ()
whenX ((XState -> Bool) -> X Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Pixel -> Set Pixel -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Pixel
w (Set Pixel -> Bool) -> (XState -> Set Pixel) -> XState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Set Pixel
mapped)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    Pixel
cMask <- (XConf -> Pixel) -> X Pixel
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> Pixel) -> X Pixel) -> (XConf -> Pixel) -> X Pixel
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> Pixel
forall (l :: * -> *). XConfig l -> Pixel
clientMask (XConfig Layout -> Pixel)
-> (XConf -> XConfig Layout) -> XConf -> Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do Display -> Pixel -> Pixel -> IO ()
selectInput Display
d Pixel
w (Pixel
cMask Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.&. Pixel -> Pixel
forall a. Bits a => a -> a
complement Pixel
structureNotifyMask)
            Display -> Pixel -> IO ()
unmapWindow Display
d Pixel
w
            Display -> Pixel -> Pixel -> IO ()
selectInput Display
d Pixel
w Pixel
cMask
    Pixel -> Int -> X ()
setWMState Pixel
w Int
iconicState
    -- this part is key: we increment the waitingUnmap counter to distinguish
    -- between client and xmonad initiated unmaps.
    (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { waitingUnmap = M.insertWith (+) w 1 (waitingUnmap s)
                    , mapped       = S.delete w (mapped s) })

-- | Show a window by mapping it and setting Normal.
-- This is harmless if the window was already visible.
reveal :: Window -> X ()
reveal :: Pixel -> X ()
reveal Pixel
w = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    Pixel -> Int -> X ()
setWMState Pixel
w Int
normalState
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO ()
mapWindow Display
d Pixel
w
    X Bool -> X () -> X ()
whenX (Pixel -> X Bool
isClient Pixel
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { mapped = S.insert w (mapped s) })

-- | Set some properties when we initially gain control of a window.
setInitialProperties :: Window -> X ()
setInitialProperties :: Pixel -> X ()
setInitialProperties Pixel
w = (XConf -> Pixel) -> X Pixel
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Pixel
normalBorder X Pixel -> (Pixel -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Pixel
nb -> (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    Pixel -> Int -> X ()
setWMState Pixel
w Int
iconicState
    (XConf -> Pixel) -> X Pixel
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> Pixel
forall (l :: * -> *). XConfig l -> Pixel
clientMask (XConfig Layout -> Pixel)
-> (XConf -> XConfig Layout) -> XConf -> Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) X Pixel -> (Pixel -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> (Pixel -> IO ()) -> Pixel -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> Pixel -> Pixel -> IO ()
selectInput Display
d Pixel
w
    Dimension
bw <- (XConf -> Dimension) -> X Dimension
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> Dimension
forall (l :: * -> *). XConfig l -> Dimension
borderWidth (XConfig Layout -> Dimension)
-> (XConf -> XConfig Layout) -> XConf -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Dimension -> IO ()
setWindowBorderWidth Display
d Pixel
w Dimension
bw
    -- we must initially set the color of new windows, to maintain invariants
    -- required by the border setting in 'windows'
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Pixel -> IO ()
setWindowBorder Display
d Pixel
w Pixel
nb

-- | Render the currently visible workspaces, as determined by
-- the 'StackSet'. Also, set focus to the focused window.
--
-- This is our 'view' operation (MVC), in that it pretty prints our model
-- with X calls.
--
refresh :: X ()
refresh :: X ()
refresh = (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
forall a. a -> a
id

-- | Remove all events of a given type from the event queue.
clearEvents :: EventMask -> X ()
clearEvents :: Pixel -> X ()
clearEvents Pixel
mask = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Display -> Bool -> IO ()
sync Display
d Bool
False
    (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
p -> (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
again -> do
        Bool
more <- Display -> Pixel -> XEventPtr -> IO Bool
checkMaskEvent Display
d Pixel
mask XEventPtr
p
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
more IO ()
again -- beautiful

-- | Move and resize @w@ such that it fits inside the given rectangle,
-- including its border.
tileWindow :: Window -> Rectangle -> X ()
tileWindow :: Pixel -> Rectangle -> X ()
tileWindow Pixel
w Rectangle
r = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> Display -> Pixel -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
d Pixel
w ((WindowAttributes -> X ()) -> X ())
-> (WindowAttributes -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowAttributes
wa -> do
    -- give all windows at least 1x1 pixels
    let bw :: Dimension
bw = CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_border_width WindowAttributes
wa
        least :: Dimension -> Dimension
least Dimension
x | Dimension
x Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
<= Dimension
bwDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
*Dimension
2  = Dimension
1
                | Bool
otherwise  = Dimension
x Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
bwDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
*Dimension
2
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display
-> Pixel -> Position -> Position -> Dimension -> Dimension -> IO ()
moveResizeWindow Display
d Pixel
w (Rectangle -> Position
rect_x Rectangle
r) (Rectangle -> Position
rect_y Rectangle
r)
                              (Dimension -> Dimension
least (Dimension -> Dimension) -> Dimension -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_width Rectangle
r) (Dimension -> Dimension
least (Dimension -> Dimension) -> Dimension -> Dimension
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_height Rectangle
r)

-- ---------------------------------------------------------------------

-- | Returns 'True' if the first rectangle is contained within, but not equal
-- to the second.
containedIn :: Rectangle -> Rectangle -> Bool
containedIn :: Rectangle -> Rectangle -> Bool
containedIn r1 :: Rectangle
r1@(Rectangle Position
x1 Position
y1 Dimension
w1 Dimension
h1) r2 :: Rectangle
r2@(Rectangle Position
x2 Position
y2 Dimension
w2 Dimension
h2)
 = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Rectangle
r1 Rectangle -> Rectangle -> Bool
forall a. Eq a => a -> a -> Bool
/= Rectangle
r2
       , Position
x1 Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
x2
       , Position
y1 Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
y2
       , Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
x1 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
w1 Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
<= Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
x2 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
w2
       , Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
y1 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
h1 Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
<= Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
y2 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
h2 ]

-- | Given a list of screens, remove all duplicated screens and screens that
-- are entirely contained within another.
nubScreens :: [Rectangle] -> [Rectangle]
nubScreens :: [Rectangle] -> [Rectangle]
nubScreens [Rectangle]
xs = [Rectangle] -> [Rectangle]
forall a. Eq a => [a] -> [a]
nub ([Rectangle] -> [Rectangle])
-> ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
x -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Rectangle
x Rectangle -> Rectangle -> Bool
`containedIn`) [Rectangle]
xs) ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ [Rectangle]
xs

-- | Clean the list of screens according to the rules documented for
-- nubScreens.
getCleanedScreenInfo :: MonadIO m => Display -> m [Rectangle]
getCleanedScreenInfo :: forall (m :: * -> *). MonadIO m => Display -> m [Rectangle]
getCleanedScreenInfo = IO [Rectangle] -> m [Rectangle]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Rectangle] -> m [Rectangle])
-> (Display -> IO [Rectangle]) -> Display -> m [Rectangle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  ([Rectangle] -> [Rectangle]) -> IO [Rectangle] -> IO [Rectangle]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Rectangle] -> [Rectangle]
nubScreens (IO [Rectangle] -> IO [Rectangle])
-> (Display -> IO [Rectangle]) -> Display -> IO [Rectangle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> IO [Rectangle]
getScreenInfo

-- | The screen configuration may have changed (due to -- xrandr),
-- update the state and refresh the screen, and reset the gap.
rescreen :: X ()
rescreen :: X ()
rescreen = (Display -> X [Rectangle]) -> X [Rectangle]
forall a. (Display -> X a) -> X a
withDisplay Display -> X [Rectangle]
forall (m :: * -> *). MonadIO m => Display -> m [Rectangle]
getCleanedScreenInfo X [Rectangle] -> ([Rectangle] -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> WorkspaceId -> X ()
forall (m :: * -> *). MonadIO m => WorkspaceId -> m ()
trace WorkspaceId
"getCleanedScreenInfo returned []"
    Rectangle
xinesc:[Rectangle]
xinescs ->
        (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ \ws :: WindowSet
ws@W.StackSet{ current :: forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current = Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
v, visible :: forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible = [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
vs, hidden :: forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
W.hidden = [Workspace WorkspaceId (Layout Pixel) Pixel]
hs } ->
            let ([Workspace WorkspaceId (Layout Pixel) Pixel]
xs, [Workspace WorkspaceId (Layout Pixel) Pixel]
ys) = Int
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> ([Workspace WorkspaceId (Layout Pixel) Pixel],
    [Workspace WorkspaceId (Layout Pixel) Pixel])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Rectangle] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rectangle]
xinescs) ((Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a b. (a -> b) -> [a] -> [b]
map Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
vs [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a. [a] -> [a] -> [a]
++ [Workspace WorkspaceId (Layout Pixel) Pixel]
hs)
                a :: Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
a = Workspace WorkspaceId (Layout Pixel) Pixel
-> ScreenId
-> ScreenDetail
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd.
Workspace i l a -> sid -> sd -> Screen i l a sid sd
W.Screen (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
v) ScreenId
0 (Rectangle -> ScreenDetail
SD Rectangle
xinesc)
                as :: [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
as = (Workspace WorkspaceId (Layout Pixel) Pixel
 -> ScreenId
 -> ScreenDetail
 -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [ScreenId]
-> [ScreenDetail]
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Workspace WorkspaceId (Layout Pixel) Pixel
-> ScreenId
-> ScreenDetail
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd.
Workspace i l a -> sid -> sd -> Screen i l a sid sd
W.Screen [Workspace WorkspaceId (Layout Pixel) Pixel]
xs [ScreenId
1..] ([ScreenDetail]
 -> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail])
-> [ScreenDetail]
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> ScreenDetail) -> [Rectangle] -> [ScreenDetail]
forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> ScreenDetail
SD [Rectangle]
xinescs
            in  WindowSet
ws { W.current = a
                   , W.visible = as
                   , W.hidden  = ys }

-- ---------------------------------------------------------------------

-- | Tell whether or not to intercept clicks on a given window
setButtonGrab :: Bool -> Window -> X ()
setButtonGrab :: Bool -> Pixel -> X ()
setButtonGrab Bool
grab Pixel
w = do
    CInt
pointerMode <- (XConf -> CInt) -> X CInt
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> CInt) -> X CInt) -> (XConf -> CInt) -> X CInt
forall a b. (a -> b) -> a -> b
$ \XConf
c -> if XConfig Layout -> Bool
forall (l :: * -> *). XConfig l -> Bool
clickJustFocuses (XConf -> XConfig Layout
config XConf
c)
                                    then CInt
grabModeAsync
                                    else CInt
grabModeSync
    (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ if Bool
grab
        then [Dimension] -> (Dimension -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Dimension
button1, Dimension
button2, Dimension
button3] ((Dimension -> IO ()) -> IO ()) -> (Dimension -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Dimension
b ->
            Display
-> Dimension
-> KeyMask
-> Pixel
-> Bool
-> Pixel
-> CInt
-> CInt
-> Pixel
-> Pixel
-> IO ()
grabButton Display
d Dimension
b KeyMask
anyModifier Pixel
w Bool
False Pixel
buttonPressMask
                       CInt
pointerMode CInt
grabModeSync Pixel
none Pixel
none
        else Display -> Dimension -> KeyMask -> Pixel -> IO ()
ungrabButton Display
d Dimension
anyButton KeyMask
anyModifier Pixel
w

-- ---------------------------------------------------------------------
-- Setting keyboard focus

-- | Set the focus to the window on top of the stack, or root
setTopFocus :: X ()
setTopFocus :: X ()
setTopFocus = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ X () -> (Pixel -> X ()) -> Maybe Pixel -> X ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Pixel -> X ()
setFocusX (Pixel -> X ()) -> X Pixel -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> Pixel) -> X Pixel
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Pixel
theRoot) Pixel -> X ()
setFocusX (Maybe Pixel -> X ())
-> (WindowSet -> Maybe Pixel) -> WindowSet -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Maybe Pixel
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek

-- | Set focus explicitly to window 'w' if it is managed by us, or root.
-- This happens if X notices we've moved the mouse (and perhaps moved
-- the mouse to a new screen).
focus :: Window -> X ()
focus :: Pixel -> X ()
focus Pixel
w = (XConf -> XConf) -> X () -> X ()
forall a. (XConf -> XConf) -> X a -> X a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\XConf
c -> XConf
c { mouseFocused = True }) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
s -> do
    let stag :: Screen c l a sid sd -> c
stag = Workspace c l a -> c
forall i l a. Workspace i l a -> i
W.tag (Workspace c l a -> c)
-> (Screen c l a sid sd -> Workspace c l a)
-> Screen c l a sid sd
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen c l a sid sd -> Workspace c l a
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace
        curr :: WorkspaceId
curr = Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> WorkspaceId
forall {c} {l} {a} {sid} {sd}. Screen c l a sid sd -> c
stag (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> WorkspaceId)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> WorkspaceId
forall a b. (a -> b) -> a -> b
$ WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
s
    Maybe WorkspaceId
mnew <- X (Maybe WorkspaceId)
-> ((Position, Position) -> X (Maybe WorkspaceId))
-> Maybe (Position, Position)
-> X (Maybe WorkspaceId)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe WorkspaceId -> X (Maybe WorkspaceId)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WorkspaceId
forall a. Maybe a
Nothing) ((Maybe
   (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
 -> Maybe WorkspaceId)
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
-> X (Maybe WorkspaceId)
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> WorkspaceId)
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Maybe WorkspaceId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> WorkspaceId
forall {c} {l} {a} {sid} {sd}. Screen c l a sid sd -> c
stag) (X (Maybe
      (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
 -> X (Maybe WorkspaceId))
-> ((Position, Position)
    -> X (Maybe
            (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)))
-> (Position, Position)
-> X (Maybe WorkspaceId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position
 -> Position
 -> X (Maybe
         (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)))
-> (Position, Position)
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Position
-> Position
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
pointScreen)
            (Maybe (Position, Position) -> X (Maybe WorkspaceId))
-> X (Maybe (Position, Position)) -> X (Maybe WorkspaceId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> Maybe (Position, Position))
-> X (Maybe (Position, Position))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Maybe (Position, Position)
mousePosition
    Pixel
root <- (XConf -> Pixel) -> X Pixel
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Pixel
theRoot
    case () of
        ()
_ | Pixel -> WindowSet -> Bool
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Bool
W.member Pixel
w WindowSet
s Bool -> Bool -> Bool
&& WindowSet -> Maybe Pixel
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
s Maybe Pixel -> Maybe Pixel -> Bool
forall a. Eq a => a -> a -> Bool
/= Pixel -> Maybe Pixel
forall a. a -> Maybe a
Just Pixel
w -> (WindowSet -> WindowSet) -> X ()
windows (Pixel -> 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 Pixel
w)
          | Just WorkspaceId
new <- Maybe WorkspaceId
mnew, Pixel
w Pixel -> Pixel -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel
root Bool -> Bool -> Bool
&& WorkspaceId
curr WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
/= WorkspaceId
new
                                               -> (WindowSet -> WindowSet) -> X ()
windows (WorkspaceId -> 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 WorkspaceId
new)
          | Bool
otherwise                          -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Call X to set the keyboard focus details.
setFocusX :: Window -> X ()
setFocusX :: Pixel -> X ()
setFocusX Pixel
w = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> do
    Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display

    -- clear mouse button grab and border on other windows
    [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> X ())
-> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: WindowSet
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible WindowSet
ws) ((Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
  -> X ())
 -> X ())
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> X ())
-> X ()
forall a b. (a -> b) -> a -> b
$ \Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
wk ->
        [Pixel] -> (Pixel -> X ()) -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (WindowSet -> [Pixel]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index (WorkspaceId -> 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 (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
wk)) WindowSet
ws)) ((Pixel -> X ()) -> X ()) -> (Pixel -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Pixel
otherw ->
            Bool -> Pixel -> X ()
setButtonGrab Bool
True Pixel
otherw

    -- If we ungrab buttons on the root window, we lose our mouse bindings.
    X Bool -> X () -> X ()
whenX (Bool -> Bool
not (Bool -> Bool) -> X Bool -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pixel -> X Bool
isRoot Pixel
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Bool -> Pixel -> X ()
setButtonGrab Bool
False Pixel
w

    WMHints
hints <- IO WMHints -> X WMHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WMHints -> X WMHints) -> IO WMHints -> X WMHints
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO WMHints
getWMHints Display
dpy Pixel
w
    [Pixel]
protocols <- IO [Pixel] -> X [Pixel]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Pixel] -> X [Pixel]) -> IO [Pixel] -> X [Pixel]
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO [Pixel]
getWMProtocols Display
dpy Pixel
w
    Pixel
wmprot <- X Pixel
atom_WM_PROTOCOLS
    Pixel
wmtf <- X Pixel
atom_WM_TAKE_FOCUS
    Maybe Event
currevt <- (XConf -> Maybe Event) -> X (Maybe Event)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Maybe Event
currentEvent
    let inputHintSet :: Bool
inputHintSet = WMHints -> CLong
wmh_flags WMHints
hints CLong -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
inputHintBit

    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
inputHintSet Bool -> Bool -> Bool
&& WMHints -> Bool
wmh_input WMHints
hints Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
inputHintSet) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
      IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do Display -> Pixel -> CInt -> Pixel -> IO ()
setInputFocus Display
dpy Pixel
w CInt
revertToPointerRoot Pixel
0
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Pixel
wmtf Pixel -> [Pixel] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pixel]
protocols) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
      IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
ev -> do
        XEventPtr -> Dimension -> IO ()
setEventType XEventPtr
ev Dimension
clientMessage
        XEventPtr -> Pixel -> Pixel -> CInt -> Pixel -> Pixel -> IO ()
setClientMessageEvent XEventPtr
ev Pixel
w Pixel
wmprot CInt
32 Pixel
wmtf (Pixel -> IO ()) -> Pixel -> IO ()
forall a b. (a -> b) -> a -> b
$ Pixel -> (Event -> Pixel) -> Maybe Event -> Pixel
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pixel
currentTime Event -> Pixel
event_time Maybe Event
currevt
        Display -> Pixel -> Bool -> Pixel -> XEventPtr -> IO ()
sendEvent Display
dpy Pixel
w Bool
False Pixel
noEventMask XEventPtr
ev
        where event_time :: Event -> Pixel
event_time Event
ev =
                if Event -> Dimension
ev_event_type Event
ev Dimension -> [Dimension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Dimension]
timedEvents then
                  Event -> Pixel
ev_time Event
ev
                else
                  Pixel
currentTime
              timedEvents :: [Dimension]
timedEvents = [ Dimension
keyPress, Dimension
keyRelease, Dimension
buttonPress, Dimension
buttonRelease, Dimension
enterNotify, Dimension
leaveNotify, Dimension
selectionRequest ]

cacheNumlockMask :: X ()
cacheNumlockMask :: X ()
cacheNumlockMask = do
    Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    [(KeyMask, [KeyCode])]
ms <- IO [(KeyMask, [KeyCode])] -> X [(KeyMask, [KeyCode])]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [(KeyMask, [KeyCode])] -> X [(KeyMask, [KeyCode])])
-> IO [(KeyMask, [KeyCode])] -> X [(KeyMask, [KeyCode])]
forall a b. (a -> b) -> a -> b
$ Display -> IO [(KeyMask, [KeyCode])]
getModifierMapping Display
dpy
    [KeyMask]
xs <- [X KeyMask] -> X [KeyMask]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ do Pixel
ks <- IO Pixel -> X Pixel
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Pixel -> X Pixel) -> IO Pixel -> X Pixel
forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO Pixel
keycodeToKeysym Display
dpy KeyCode
kc CInt
0
                        if Pixel
ks Pixel -> Pixel -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel
xK_Num_Lock
                            then KeyMask -> X KeyMask
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMask -> Int -> KeyMask
forall a. Bits a => a -> Int -> a
setBit KeyMask
0 (KeyMask -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral KeyMask
m))
                            else KeyMask -> X KeyMask
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMask
0 :: KeyMask)
                   | (KeyMask
m, [KeyCode]
kcs) <- [(KeyMask, [KeyCode])]
ms, KeyCode
kc <- [KeyCode]
kcs, KeyCode
kc KeyCode -> KeyCode -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyCode
0
                   ]
    (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { numberlockMask = foldr (.|.) 0 xs })

-- | Given a list of keybindings, turn the given 'KeySym's into actual
-- 'KeyCode's and prepare them for grabbing.
mkGrabs :: [(KeyMask, KeySym)] -> X [(KeyMask, KeyCode)]
mkGrabs :: [(KeyMask, Pixel)] -> X [(KeyMask, KeyCode)]
mkGrabs [(KeyMask, Pixel)]
ks = (Display -> X [(KeyMask, KeyCode)]) -> X [(KeyMask, KeyCode)]
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X [(KeyMask, KeyCode)]) -> X [(KeyMask, KeyCode)])
-> (Display -> X [(KeyMask, KeyCode)]) -> X [(KeyMask, KeyCode)]
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    let (CInt
minCode, CInt
maxCode) = Display -> (CInt, CInt)
displayKeycodes Display
dpy
        allCodes :: [KeyCode]
allCodes = [CInt -> KeyCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
minCode .. CInt -> KeyCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
maxCode]
    -- build a map from keysyms to lists of keysyms (doing what
    -- XGetKeyboardMapping would do if the X11 package bound it)
    [Pixel]
syms <- [KeyCode] -> (KeyCode -> X Pixel) -> X [Pixel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [KeyCode]
allCodes ((KeyCode -> X Pixel) -> X [Pixel])
-> (KeyCode -> X Pixel) -> X [Pixel]
forall a b. (a -> b) -> a -> b
$ \KeyCode
code -> IO Pixel -> X Pixel
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> CInt -> IO Pixel
keycodeToKeysym Display
dpy KeyCode
code CInt
0)
    let -- keycodeToKeysym returns noSymbol for all unbound keycodes,
        -- and we don't want to grab those whenever someone accidentally
        -- uses def :: KeySym
        keysymMap :: Map Pixel [KeyCode]
keysymMap = Pixel -> Map Pixel [KeyCode] -> Map Pixel [KeyCode]
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Pixel
noSymbol (Map Pixel [KeyCode] -> Map Pixel [KeyCode])
-> Map Pixel [KeyCode] -> Map Pixel [KeyCode]
forall a b. (a -> b) -> a -> b
$
            ([KeyCode] -> [KeyCode] -> [KeyCode])
-> [(Pixel, [KeyCode])] -> Map Pixel [KeyCode]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [KeyCode] -> [KeyCode] -> [KeyCode]
forall a. [a] -> [a] -> [a]
(++) ([Pixel] -> [[KeyCode]] -> [(Pixel, [KeyCode])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixel]
syms [[KeyCode
code] | KeyCode
code <- [KeyCode]
allCodes])
        keysymToKeycodes :: Pixel -> [KeyCode]
keysymToKeycodes Pixel
sym = [KeyCode] -> Pixel -> Map Pixel [KeyCode] -> [KeyCode]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] Pixel
sym Map Pixel [KeyCode]
keysymMap
    [KeyMask]
extraMods <- X [KeyMask]
extraModifiers
    [(KeyMask, KeyCode)] -> X [(KeyMask, KeyCode)]
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (KeyMask
mask KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
extraMod, KeyCode
keycode)
         | (KeyMask
mask, Pixel
sym) <- [(KeyMask, Pixel)]
ks
         , KeyCode
keycode     <- Pixel -> [KeyCode]
keysymToKeycodes Pixel
sym
         , KeyMask
extraMod    <- [KeyMask]
extraMods
         ]

-- | Release XMonad's keyboard grab, so other grabbers can do their thing.
--
-- Start a keyboard action with this if it is going to run something
-- that needs to do a keyboard, pointer, or server grab. For example,
--
-- > , ((modm .|. controlMask, xK_p), unGrab >> spawn "scrot")
--
-- (Other examples are certain screen lockers and "gksu".)
-- This avoids needing to insert a pause/sleep before running the
-- command.
--
-- XMonad retains the keyboard grab during key actions because if they
-- use a submap, they need the keyboard to be grabbed, and if they had
-- to assert their own grab then the asynchronous nature of X11 allows
-- race conditions between XMonad, other clients, and the X server that
-- would cause keys to sometimes be "leaked" to the focused window.
unGrab :: X ()
unGrab :: X ()
unGrab = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Display -> Pixel -> IO ()
ungrabKeyboard Display
d Pixel
currentTime
    Display -> Pixel -> IO ()
ungrabPointer  Display
d Pixel
currentTime
    Display -> Bool -> IO ()
sync Display
d Bool
False

------------------------------------------------------------------------
-- Message handling

-- | Throw a message to the current 'LayoutClass' possibly modifying how we
-- layout the windows, in which case changes are handled through a refresh.
sendMessage :: Message a => a -> X ()
sendMessage :: forall a. Message a => a -> X ()
sendMessage a
a = X Any -> X ()
windowBracket_ (X Any -> X ()) -> X Any -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Workspace WorkspaceId (Layout Pixel) Pixel
w <- (XState -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> X (Workspace WorkspaceId (Layout Pixel) Pixel)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Workspace WorkspaceId (Layout Pixel) Pixel)
 -> X (Workspace WorkspaceId (Layout Pixel) Pixel))
-> (XState -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> X (Workspace WorkspaceId (Layout Pixel) Pixel)
forall a b. (a -> b) -> a -> b
$ Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> (XState
    -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> XState
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet
 -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> (XState -> WindowSet)
-> XState
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
    Maybe (Layout Pixel)
ml' <- Layout Pixel -> SomeMessage -> X (Maybe (Layout Pixel))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage (Workspace WorkspaceId (Layout Pixel) Pixel -> Layout Pixel
forall i l a. Workspace i l a -> l
W.layout Workspace WorkspaceId (Layout Pixel) Pixel
w) (a -> SomeMessage
forall a. Message a => a -> SomeMessage
SomeMessage a
a) X (Maybe (Layout Pixel))
-> X (Maybe (Layout Pixel)) -> X (Maybe (Layout Pixel))
forall a. X a -> X a -> X a
`catchX` Maybe (Layout Pixel) -> X (Maybe (Layout Pixel))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Layout Pixel)
forall a. Maybe a
Nothing
    Maybe (Layout Pixel) -> (Layout Pixel -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Layout Pixel)
ml' ((Layout Pixel -> X ()) -> X ()) -> (Layout Pixel -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Layout Pixel
l' ->
        (WindowSet -> WindowSet) -> X ()
modifyWindowSet ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> WindowSet
ws { W.current = (W.current ws)
                                { W.workspace = (W.workspace $ W.current ws)
                                  { W.layout = l' }}}
    Any -> X Any
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any (Bool -> Any) -> Bool -> Any
forall a b. (a -> b) -> a -> b
$ Maybe (Layout Pixel) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Layout Pixel)
ml')

-- | Send a message to all layouts, without refreshing.
broadcastMessage :: Message a => a -> X ()
broadcastMessage :: forall a. Message a => a -> X ()
broadcastMessage a
a = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> do
    -- this is O(n²), but we can't really fix this as there's code in
    -- xmonad-contrib that touches the windowset during handleMessage
    -- (returning Nothing for changes to not get overwritten), so we
    -- unfortunately need to do this one by one and persist layout states
    -- of each workspace separately)
    let c :: Workspace WorkspaceId (Layout Pixel) Pixel
c = Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> (WindowSet
    -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> WindowSet
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> WindowSet -> Workspace WorkspaceId (Layout Pixel) Pixel
forall a b. (a -> b) -> a -> b
$ WindowSet
ws
        v :: [Workspace WorkspaceId (Layout Pixel) Pixel]
v = (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a b. (a -> b) -> [a] -> [b]
map Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace ([Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
 -> [Workspace WorkspaceId (Layout Pixel) Pixel])
-> (WindowSet
    -> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail])
-> WindowSet
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible (WindowSet -> [Workspace WorkspaceId (Layout Pixel) Pixel])
-> WindowSet -> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a b. (a -> b) -> a -> b
$ WindowSet
ws
        h :: [Workspace WorkspaceId (Layout Pixel) Pixel]
h = WindowSet -> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
W.hidden WindowSet
ws
    (Workspace WorkspaceId (Layout Pixel) Pixel -> X ())
-> [Workspace WorkspaceId (Layout Pixel) Pixel] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (a -> Workspace WorkspaceId (Layout Pixel) Pixel -> X ()
forall a.
Message a =>
a -> Workspace WorkspaceId (Layout Pixel) Pixel -> X ()
sendMessageWithNoRefresh a
a) (Workspace WorkspaceId (Layout Pixel) Pixel
c Workspace WorkspaceId (Layout Pixel) Pixel
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a. a -> [a] -> [a]
: [Workspace WorkspaceId (Layout Pixel) Pixel]
v [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall a. [a] -> [a] -> [a]
++ [Workspace WorkspaceId (Layout Pixel) Pixel]
h)

-- | Send a message to a layout, without refreshing.
sendMessageWithNoRefresh :: Message a => a -> WindowSpace -> X ()
sendMessageWithNoRefresh :: forall a.
Message a =>
a -> Workspace WorkspaceId (Layout Pixel) Pixel -> X ()
sendMessageWithNoRefresh a
a Workspace WorkspaceId (Layout Pixel) Pixel
w =
    Layout Pixel -> SomeMessage -> X (Maybe (Layout Pixel))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage (Workspace WorkspaceId (Layout Pixel) Pixel -> Layout Pixel
forall i l a. Workspace i l a -> l
W.layout Workspace WorkspaceId (Layout Pixel) Pixel
w) (a -> SomeMessage
forall a. Message a => a -> SomeMessage
SomeMessage a
a) X (Maybe (Layout Pixel))
-> X (Maybe (Layout Pixel)) -> X (Maybe (Layout Pixel))
forall a. X a -> X a -> X a
`catchX` Maybe (Layout Pixel) -> X (Maybe (Layout Pixel))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Layout Pixel)
forall a. Maybe a
Nothing X (Maybe (Layout Pixel)) -> (Maybe (Layout Pixel) -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    WorkspaceId -> Maybe (Layout Pixel) -> X ()
updateLayout  (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag Workspace WorkspaceId (Layout Pixel) Pixel
w)

-- | Update the layout field of a workspace.
updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X ()
updateLayout :: WorkspaceId -> Maybe (Layout Pixel) -> X ()
updateLayout WorkspaceId
i Maybe (Layout Pixel)
ml = Maybe (Layout Pixel) -> (Layout Pixel -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Layout Pixel)
ml ((Layout Pixel -> X ()) -> X ()) -> (Layout Pixel -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Layout Pixel
l ->
    (Workspace WorkspaceId (Layout Pixel) Pixel
 -> X (Workspace WorkspaceId (Layout Pixel) Pixel))
-> X ()
runOnWorkspaces ((Workspace WorkspaceId (Layout Pixel) Pixel
  -> X (Workspace WorkspaceId (Layout Pixel) Pixel))
 -> X ())
-> (Workspace WorkspaceId (Layout Pixel) Pixel
    -> X (Workspace WorkspaceId (Layout Pixel) Pixel))
-> X ()
forall a b. (a -> b) -> a -> b
$ \Workspace WorkspaceId (Layout Pixel) Pixel
ww -> Workspace WorkspaceId (Layout Pixel) Pixel
-> X (Workspace WorkspaceId (Layout Pixel) Pixel)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Workspace WorkspaceId (Layout Pixel) Pixel
 -> X (Workspace WorkspaceId (Layout Pixel) Pixel))
-> Workspace WorkspaceId (Layout Pixel) Pixel
-> X (Workspace WorkspaceId (Layout Pixel) Pixel)
forall a b. (a -> b) -> a -> b
$ if Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag Workspace WorkspaceId (Layout Pixel) Pixel
ww WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
== WorkspaceId
i then Workspace WorkspaceId (Layout Pixel) Pixel
ww { W.layout = l} else Workspace WorkspaceId (Layout Pixel) Pixel
ww

-- | Set the layout of the currently viewed workspace.
setLayout :: Layout Window -> X ()
setLayout :: Layout Pixel -> X ()
setLayout Layout Pixel
l = do
    ss :: WindowSet
ss@W.StackSet{ current :: forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current = c :: Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
c@W.Screen{ workspace :: forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace = Workspace WorkspaceId (Layout Pixel) Pixel
ws }} <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    Layout Pixel -> SomeMessage -> X (Maybe (Layout Pixel))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage (Workspace WorkspaceId (Layout Pixel) Pixel -> Layout Pixel
forall i l a. Workspace i l a -> l
W.layout Workspace WorkspaceId (Layout Pixel) Pixel
ws) (LayoutMessages -> SomeMessage
forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
    (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ WindowSet -> WindowSet -> WindowSet
forall a b. a -> b -> a
const (WindowSet -> WindowSet -> WindowSet)
-> WindowSet -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ WindowSet
ss{ W.current = c{ W.workspace = ws{ W.layout = l } } }

-- | Signal xmonad to restart itself.
sendRestart :: IO ()
sendRestart :: IO ()
sendRestart = do
    Display
dpy <- WorkspaceId -> IO Display
openDisplay WorkspaceId
""
    Pixel
rw  <- Display -> Dimension -> IO Pixel
rootWindow Display
dpy (Dimension -> IO Pixel) -> Dimension -> IO Pixel
forall a b. (a -> b) -> a -> b
$ Display -> Dimension
defaultScreen Display
dpy
    Pixel
xmonad_restart <- Display -> WorkspaceId -> Bool -> IO Pixel
internAtom Display
dpy WorkspaceId
"XMONAD_RESTART" Bool
False
    (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
        XEventPtr -> Dimension -> IO ()
setEventType XEventPtr
e Dimension
clientMessage
        XEventPtr -> Pixel -> Pixel -> CInt -> [CInt] -> IO ()
setClientMessageEvent' XEventPtr
e Pixel
rw Pixel
xmonad_restart CInt
32 []
        Display -> Pixel -> Bool -> Pixel -> XEventPtr -> IO ()
sendEvent Display
dpy Pixel
rw Bool
False Pixel
structureNotifyMask XEventPtr
e
    Display -> Bool -> IO ()
sync Display
dpy Bool
False

-- | Signal compliant window managers to exit.
sendReplace :: IO ()
sendReplace :: IO ()
sendReplace = do
    Display
dpy <- WorkspaceId -> IO Display
openDisplay WorkspaceId
""
    let dflt :: Dimension
dflt = Display -> Dimension
defaultScreen Display
dpy
    Pixel
rootw <- Display -> Dimension -> IO Pixel
rootWindow Display
dpy Dimension
dflt
    Display -> Dimension -> Pixel -> IO ()
replace Display
dpy Dimension
dflt Pixel
rootw

-- | Signal compliant window managers to exit.
replace :: Display -> ScreenNumber -> Window -> IO ()
replace :: Display -> Dimension -> Pixel -> IO ()
replace Display
dpy Dimension
dflt Pixel
rootw = do
    -- check for other WM
    Pixel
wmSnAtom <- Display -> WorkspaceId -> Bool -> IO Pixel
internAtom Display
dpy (WorkspaceId
"WM_S" WorkspaceId -> WorkspaceId -> WorkspaceId
forall a. [a] -> [a] -> [a]
++ Dimension -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show Dimension
dflt) Bool
False
    Pixel
currentWmSnOwner <- Display -> Pixel -> IO Pixel
xGetSelectionOwner Display
dpy Pixel
wmSnAtom
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Pixel
currentWmSnOwner Pixel -> Pixel -> Bool
forall a. Eq a => a -> a -> Bool
/= Pixel
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- prepare to receive destroyNotify for old WM
        Display -> Pixel -> Pixel -> IO ()
selectInput Display
dpy Pixel
currentWmSnOwner Pixel
structureNotifyMask

        -- create off-screen window
        Pixel
netWmSnOwner <- (Ptr SetWindowAttributes -> IO Pixel) -> IO Pixel
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Pixel) -> IO Pixel)
-> (Ptr SetWindowAttributes -> IO Pixel) -> IO Pixel
forall a b. (a -> b) -> a -> b
$ \Ptr SetWindowAttributes
attributes -> do
            Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
True
            Ptr SetWindowAttributes -> Pixel -> IO ()
set_event_mask Ptr SetWindowAttributes
attributes Pixel
propertyChangeMask
            let screen :: Screen
screen = Display -> Screen
defaultScreenOfDisplay Display
dpy
                visual :: Visual
visual = Screen -> Visual
defaultVisualOfScreen Screen
screen
                attrmask :: Pixel
attrmask = Pixel
cWOverrideRedirect Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
cWEventMask
            Display
-> Pixel
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> CInt
-> Visual
-> Pixel
-> Ptr SetWindowAttributes
-> IO Pixel
createWindow Display
dpy Pixel
rootw (-Position
100) (-Position
100) Dimension
1 Dimension
1 CInt
0 CInt
copyFromParent CInt
copyFromParent Visual
visual Pixel
attrmask Ptr SetWindowAttributes
attributes

        -- try to acquire wmSnAtom, this should signal the old WM to terminate
        Display -> Pixel -> Pixel -> Pixel -> IO ()
xSetSelectionOwner Display
dpy Pixel
wmSnAtom Pixel
netWmSnOwner Pixel
currentTime

        -- SKIPPED: check if we acquired the selection
        -- SKIPPED: send client message indicating that we are now the WM

        -- wait for old WM to go away
        (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
again -> do
            Dimension
evt <- (XEventPtr -> IO Dimension) -> IO Dimension
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO Dimension) -> IO Dimension)
-> (XEventPtr -> IO Dimension) -> IO Dimension
forall a b. (a -> b) -> a -> b
$ \XEventPtr
event -> do
                Display -> Pixel -> Pixel -> XEventPtr -> IO ()
windowEvent Display
dpy Pixel
currentWmSnOwner Pixel
structureNotifyMask XEventPtr
event
                XEventPtr -> IO Dimension
get_EventType XEventPtr
event

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
evt Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
/= Dimension
destroyNotify) IO ()
again

------------------------------------------------------------------------
-- Utilities

-- | Return workspace visible on screen @sc@, or 'Nothing'.
screenWorkspace :: ScreenId -> X (Maybe WorkspaceId)
screenWorkspace :: ScreenId -> X (Maybe WorkspaceId)
screenWorkspace ScreenId
sc = (WindowSet -> X (Maybe WorkspaceId)) -> X (Maybe WorkspaceId)
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X (Maybe WorkspaceId)) -> X (Maybe WorkspaceId))
-> (WindowSet -> X (Maybe WorkspaceId)) -> X (Maybe WorkspaceId)
forall a b. (a -> b) -> a -> b
$ Maybe WorkspaceId -> X (Maybe WorkspaceId)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe WorkspaceId -> X (Maybe WorkspaceId))
-> (WindowSet -> Maybe WorkspaceId)
-> WindowSet
-> X (Maybe WorkspaceId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScreenId -> WindowSet -> Maybe WorkspaceId
forall s i l a sd. Eq s => s -> StackSet i l a s sd -> Maybe i
W.lookupWorkspace ScreenId
sc

-- | Apply an 'X' operation to the currently focused window, if there is one.
withFocused :: (Window -> X ()) -> X ()
withFocused :: (Pixel -> X ()) -> X ()
withFocused Pixel -> X ()
f = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
w -> Maybe Pixel -> (Pixel -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (WindowSet -> Maybe Pixel
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
w) Pixel -> X ()
f

-- | Apply an 'X' operation to all unfocused windows on the current workspace, if there are any.
withUnfocused :: (Window -> X ()) -> X ()
withUnfocused :: (Pixel -> X ()) -> X ()
withUnfocused Pixel -> X ()
f = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws ->
    Maybe Pixel -> (Pixel -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (WindowSet -> Maybe Pixel
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
ws) ((Pixel -> X ()) -> X ()) -> (Pixel -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Pixel
w ->
        let unfocusedWindows :: [Pixel]
unfocusedWindows = (Pixel -> Bool) -> [Pixel] -> [Pixel]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pixel -> Pixel -> Bool
forall a. Eq a => a -> a -> Bool
/= Pixel
w) ([Pixel] -> [Pixel]) -> [Pixel] -> [Pixel]
forall a b. (a -> b) -> a -> b
$ WindowSet -> [Pixel]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index WindowSet
ws
        in (Pixel -> X ()) -> [Pixel] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Pixel -> X ()
f [Pixel]
unfocusedWindows

-- | Is the window is under management by xmonad?
isClient :: Window -> X Bool
isClient :: Pixel -> X Bool
isClient Pixel
w = (WindowSet -> X Bool) -> X Bool
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X Bool) -> X Bool)
-> (WindowSet -> X Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> X Bool) -> (WindowSet -> Bool) -> WindowSet -> X Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel -> WindowSet -> Bool
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Bool
W.member Pixel
w

-- | Combinations of extra modifier masks we need to grab keys\/buttons for.
-- (numlock and capslock)
extraModifiers :: X [KeyMask]
extraModifiers :: X [KeyMask]
extraModifiers = do
    KeyMask
nlm <- (XState -> KeyMask) -> X KeyMask
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> KeyMask
numberlockMask
    [KeyMask] -> X [KeyMask]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return [KeyMask
0, KeyMask
nlm, KeyMask
lockMask, KeyMask
nlm KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
lockMask ]

-- | Strip numlock\/capslock from a mask.
cleanMask :: KeyMask -> X KeyMask
cleanMask :: KeyMask -> X KeyMask
cleanMask KeyMask
km = do
    KeyMask
nlm <- (XState -> KeyMask) -> X KeyMask
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> KeyMask
numberlockMask
    KeyMask -> X KeyMask
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMask -> KeyMask
forall a. Bits a => a -> a
complement (KeyMask
nlm KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
lockMask) KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.&. KeyMask
km)

-- | Set the 'Pixel' alpha value to 255.
setPixelSolid :: Pixel -> Pixel
setPixelSolid :: Pixel -> Pixel
setPixelSolid Pixel
p = Pixel
p Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
0xff000000

-- | Get the 'Pixel' value for a named color.
initColor :: Display -> String -> IO (Maybe Pixel)
initColor :: Display -> WorkspaceId -> IO (Maybe Pixel)
initColor Display
dpy WorkspaceId
c = (SomeException -> IO (Maybe Pixel))
-> IO (Maybe Pixel) -> IO (Maybe Pixel)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle (\(C.SomeException e
_) -> Maybe Pixel -> IO (Maybe Pixel)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pixel
forall a. Maybe a
Nothing) (IO (Maybe Pixel) -> IO (Maybe Pixel))
-> IO (Maybe Pixel) -> IO (Maybe Pixel)
forall a b. (a -> b) -> a -> b
$
    Pixel -> Maybe Pixel
forall a. a -> Maybe a
Just (Pixel -> Maybe Pixel)
-> ((Color, Color) -> Pixel) -> (Color, Color) -> Maybe Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel -> Pixel
setPixelSolid (Pixel -> Pixel)
-> ((Color, Color) -> Pixel) -> (Color, Color) -> Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Pixel
color_pixel (Color -> Pixel)
-> ((Color, Color) -> Color) -> (Color, Color) -> Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color, Color) -> Color
forall a b. (a, b) -> a
fst ((Color, Color) -> Maybe Pixel)
-> IO (Color, Color) -> IO (Maybe Pixel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Pixel -> WorkspaceId -> IO (Color, Color)
allocNamedColor Display
dpy Pixel
colormap WorkspaceId
c
    where colormap :: Pixel
colormap = Display -> Dimension -> Pixel
defaultColormap Display
dpy (Display -> Dimension
defaultScreen Display
dpy)

------------------------------------------------------------------------

-- | A type to help serialize xmonad's state to a file.
data StateFile = StateFile
  { StateFile
-> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
sfWins :: W.StackSet  WorkspaceId String Window ScreenId ScreenDetail
  , StateFile -> [(WorkspaceId, WorkspaceId)]
sfExt  :: [(String, String)]
  } deriving (Int -> StateFile -> WorkspaceId -> WorkspaceId
[StateFile] -> WorkspaceId -> WorkspaceId
StateFile -> WorkspaceId
(Int -> StateFile -> WorkspaceId -> WorkspaceId)
-> (StateFile -> WorkspaceId)
-> ([StateFile] -> WorkspaceId -> WorkspaceId)
-> Show StateFile
forall a.
(Int -> a -> WorkspaceId -> WorkspaceId)
-> (a -> WorkspaceId)
-> ([a] -> WorkspaceId -> WorkspaceId)
-> Show a
$cshowsPrec :: Int -> StateFile -> WorkspaceId -> WorkspaceId
showsPrec :: Int -> StateFile -> WorkspaceId -> WorkspaceId
$cshow :: StateFile -> WorkspaceId
show :: StateFile -> WorkspaceId
$cshowList :: [StateFile] -> WorkspaceId -> WorkspaceId
showList :: [StateFile] -> WorkspaceId -> WorkspaceId
Show, ReadPrec [StateFile]
ReadPrec StateFile
Int -> ReadS StateFile
ReadS [StateFile]
(Int -> ReadS StateFile)
-> ReadS [StateFile]
-> ReadPrec StateFile
-> ReadPrec [StateFile]
-> Read StateFile
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StateFile
readsPrec :: Int -> ReadS StateFile
$creadList :: ReadS [StateFile]
readList :: ReadS [StateFile]
$creadPrec :: ReadPrec StateFile
readPrec :: ReadPrec StateFile
$creadListPrec :: ReadPrec [StateFile]
readListPrec :: ReadPrec [StateFile]
Read)

-- | Write the current window state (and extensible state) to a file
-- so that xmonad can resume with that state intact.
writeStateToFile :: X ()
writeStateToFile :: X ()
writeStateToFile = do
    let maybeShow :: (a, Either WorkspaceId StateExtension) -> Maybe (a, WorkspaceId)
maybeShow (a
t, Right (PersistentExtension a
ext)) = (a, WorkspaceId) -> Maybe (a, WorkspaceId)
forall a. a -> Maybe a
Just (a
t, a -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show a
ext)
        maybeShow (a
t, Left WorkspaceId
str) = (a, WorkspaceId) -> Maybe (a, WorkspaceId)
forall a. a -> Maybe a
Just (a
t, WorkspaceId
str)
        maybeShow (a, Either WorkspaceId StateExtension)
_ = Maybe (a, WorkspaceId)
forall a. Maybe a
Nothing

        wsData :: XState
-> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
wsData   = (Layout Pixel -> WorkspaceId)
-> WindowSet
-> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
forall l l' i a s sd.
(l -> l') -> StackSet i l a s sd -> StackSet i l' a s sd
W.mapLayout Layout Pixel -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show (WindowSet
 -> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail)
-> (XState -> WindowSet)
-> XState
-> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
        extState :: XState -> [(WorkspaceId, WorkspaceId)]
extState = ((WorkspaceId, Either WorkspaceId StateExtension)
 -> Maybe (WorkspaceId, WorkspaceId))
-> [(WorkspaceId, Either WorkspaceId StateExtension)]
-> [(WorkspaceId, WorkspaceId)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (WorkspaceId, Either WorkspaceId StateExtension)
-> Maybe (WorkspaceId, WorkspaceId)
forall {a}.
(a, Either WorkspaceId StateExtension) -> Maybe (a, WorkspaceId)
maybeShow ([(WorkspaceId, Either WorkspaceId StateExtension)]
 -> [(WorkspaceId, WorkspaceId)])
-> (XState -> [(WorkspaceId, Either WorkspaceId StateExtension)])
-> XState
-> [(WorkspaceId, WorkspaceId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map WorkspaceId (Either WorkspaceId StateExtension)
-> [(WorkspaceId, Either WorkspaceId StateExtension)]
forall k a. Map k a -> [(k, a)]
M.toList (Map WorkspaceId (Either WorkspaceId StateExtension)
 -> [(WorkspaceId, Either WorkspaceId StateExtension)])
-> (XState -> Map WorkspaceId (Either WorkspaceId StateExtension))
-> XState
-> [(WorkspaceId, Either WorkspaceId StateExtension)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Map WorkspaceId (Either WorkspaceId StateExtension)
extensibleState

    WorkspaceId
path <- (XConf -> WorkspaceId) -> X WorkspaceId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> WorkspaceId) -> X WorkspaceId)
-> (XConf -> WorkspaceId) -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ Directories -> WorkspaceId
stateFileName (Directories -> WorkspaceId)
-> (XConf -> Directories) -> XConf -> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories
directories
    StateFile
stateData <- (XState -> StateFile) -> X StateFile
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (\XState
s -> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
-> [(WorkspaceId, WorkspaceId)] -> StateFile
StateFile (XState
-> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
wsData XState
s) (XState -> [(WorkspaceId, WorkspaceId)]
extState XState
s))
    IO () -> X ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (WorkspaceId -> WorkspaceId -> IO ()
writeFile WorkspaceId
path (WorkspaceId -> IO ()) -> WorkspaceId -> IO ()
forall a b. (a -> b) -> a -> b
$ StateFile -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show StateFile
stateData)

-- | Read the state of a previous xmonad instance from a file and
-- return that state.  The state file is removed after reading it.
readStateFile :: (LayoutClass l Window, Read (l Window)) => XConfig l -> X (Maybe XState)
readStateFile :: forall (l :: * -> *).
(LayoutClass l Pixel, Read (l Pixel)) =>
XConfig l -> X (Maybe XState)
readStateFile XConfig l
xmc = do
    WorkspaceId
path <- (XConf -> WorkspaceId) -> X WorkspaceId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> WorkspaceId) -> X WorkspaceId)
-> (XConf -> WorkspaceId) -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ Directories -> WorkspaceId
stateFileName (Directories -> WorkspaceId)
-> (XConf -> Directories) -> XConf -> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories
directories

    -- I'm trying really hard here to make sure we read the entire
    -- contents of the file before it is removed from the file system.
    Maybe (Maybe StateFile)
sf' <- X (Maybe StateFile) -> X (Maybe (Maybe StateFile))
forall a. X a -> X (Maybe a)
userCode (X (Maybe StateFile) -> X (Maybe (Maybe StateFile)))
-> (IO (Maybe StateFile) -> X (Maybe StateFile))
-> IO (Maybe StateFile)
-> X (Maybe (Maybe StateFile))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe StateFile) -> X (Maybe StateFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe StateFile) -> X (Maybe (Maybe StateFile)))
-> IO (Maybe StateFile) -> X (Maybe (Maybe StateFile))
forall a b. (a -> b) -> a -> b
$ do
        WorkspaceId
raw <- WorkspaceId
-> IOMode -> (Handle -> IO WorkspaceId) -> IO WorkspaceId
forall r. WorkspaceId -> IOMode -> (Handle -> IO r) -> IO r
withFile WorkspaceId
path IOMode
ReadMode Handle -> IO WorkspaceId
readStrict
        Maybe StateFile -> IO (Maybe StateFile)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StateFile -> IO (Maybe StateFile))
-> Maybe StateFile -> IO (Maybe StateFile)
forall a b. (a -> b) -> a -> b
$! ReadS StateFile -> WorkspaceId -> Maybe StateFile
forall {t} {a}. (t -> [(a, WorkspaceId)]) -> t -> Maybe a
maybeRead ReadS StateFile
forall a. Read a => ReadS a
reads WorkspaceId
raw

    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (WorkspaceId -> IO ()
removeFile WorkspaceId
path)

    Maybe XState -> X (Maybe XState)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe XState -> X (Maybe XState))
-> Maybe XState -> X (Maybe XState)
forall a b. (a -> b) -> a -> b
$ do
      StateFile
sf <- Maybe (Maybe StateFile) -> Maybe StateFile
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe StateFile)
sf'

      let winset :: WindowSet
winset = Layout Pixel -> [WorkspaceId] -> WindowSet -> WindowSet
forall i l a s sd.
Eq i =>
l -> [i] -> StackSet i l a s sd -> StackSet i l a s sd
W.ensureTags Layout Pixel
layout (XConfig l -> [WorkspaceId]
forall (l :: * -> *). XConfig l -> [WorkspaceId]
workspaces XConfig l
xmc) (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ (WorkspaceId -> Layout Pixel)
-> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
-> WindowSet
forall l l' i a s sd.
(l -> l') -> StackSet i l a s sd -> StackSet i l' a s sd
W.mapLayout (Layout Pixel -> Maybe (Layout Pixel) -> Layout Pixel
forall a. a -> Maybe a -> a
fromMaybe Layout Pixel
layout (Maybe (Layout Pixel) -> Layout Pixel)
-> (WorkspaceId -> Maybe (Layout Pixel))
-> WorkspaceId
-> Layout Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceId -> [(Layout Pixel, WorkspaceId)])
-> WorkspaceId -> Maybe (Layout Pixel)
forall {t} {a}. (t -> [(a, WorkspaceId)]) -> t -> Maybe a
maybeRead WorkspaceId -> [(Layout Pixel, WorkspaceId)]
lreads) (StateFile
-> StackSet WorkspaceId WorkspaceId Pixel ScreenId ScreenDetail
sfWins StateFile
sf)
          extState :: Map WorkspaceId (Either WorkspaceId b)
extState = [(WorkspaceId, Either WorkspaceId b)]
-> Map WorkspaceId (Either WorkspaceId b)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(WorkspaceId, Either WorkspaceId b)]
 -> Map WorkspaceId (Either WorkspaceId b))
-> ([(WorkspaceId, WorkspaceId)]
    -> [(WorkspaceId, Either WorkspaceId b)])
-> [(WorkspaceId, WorkspaceId)]
-> Map WorkspaceId (Either WorkspaceId b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((WorkspaceId, WorkspaceId) -> (WorkspaceId, Either WorkspaceId b))
-> [(WorkspaceId, WorkspaceId)]
-> [(WorkspaceId, Either WorkspaceId b)]
forall a b. (a -> b) -> [a] -> [b]
map ((WorkspaceId -> Either WorkspaceId b)
-> (WorkspaceId, WorkspaceId)
-> (WorkspaceId, Either WorkspaceId b)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second WorkspaceId -> Either WorkspaceId b
forall a b. a -> Either a b
Left) ([(WorkspaceId, WorkspaceId)]
 -> Map WorkspaceId (Either WorkspaceId b))
-> [(WorkspaceId, WorkspaceId)]
-> Map WorkspaceId (Either WorkspaceId b)
forall a b. (a -> b) -> a -> b
$ StateFile -> [(WorkspaceId, WorkspaceId)]
sfExt StateFile
sf

      XState -> Maybe XState
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return XState { windowset :: WindowSet
windowset       = WindowSet
winset
                    , numberlockMask :: KeyMask
numberlockMask  = KeyMask
0
                    , mapped :: Set Pixel
mapped          = Set Pixel
forall a. Set a
S.empty
                    , waitingUnmap :: Map Pixel Int
waitingUnmap    = Map Pixel Int
forall k a. Map k a
M.empty
                    , dragging :: Maybe (Position -> Position -> X (), X ())
dragging        = Maybe (Position -> Position -> X (), X ())
forall a. Maybe a
Nothing
                    , extensibleState :: Map WorkspaceId (Either WorkspaceId StateExtension)
extensibleState = Map WorkspaceId (Either WorkspaceId StateExtension)
forall {b}. Map WorkspaceId (Either WorkspaceId b)
extState
                    }
  where
    layout :: Layout Pixel
layout = l Pixel -> Layout Pixel
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout (XConfig l -> l Pixel
forall (l :: * -> *). XConfig l -> l Pixel
layoutHook XConfig l
xmc)
    lreads :: WorkspaceId -> [(Layout Pixel, WorkspaceId)]
lreads = Layout Pixel -> WorkspaceId -> [(Layout Pixel, WorkspaceId)]
forall a. Layout a -> WorkspaceId -> [(Layout a, WorkspaceId)]
readsLayout Layout Pixel
layout
    maybeRead :: (t -> [(a, WorkspaceId)]) -> t -> Maybe a
maybeRead t -> [(a, WorkspaceId)]
reads' t
s = case t -> [(a, WorkspaceId)]
reads' t
s of
                           [(a
x, WorkspaceId
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
                           [(a, WorkspaceId)]
_         -> Maybe a
forall a. Maybe a
Nothing

    readStrict :: Handle -> IO String
    readStrict :: Handle -> IO WorkspaceId
readStrict Handle
h = Handle -> IO WorkspaceId
hGetContents Handle
h IO WorkspaceId -> (WorkspaceId -> IO WorkspaceId) -> IO WorkspaceId
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WorkspaceId
s -> WorkspaceId -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length WorkspaceId
s Int -> IO WorkspaceId -> IO WorkspaceId
forall a b. a -> b -> b
`seq` WorkspaceId -> IO WorkspaceId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceId
s

-- | @restart name resume@ attempts to restart xmonad by executing the program
-- @name@. If @resume@ is 'True', restart with the current window state.
-- When executing another window manager, @resume@ should be 'False'.
restart :: String -> Bool -> X ()
restart :: WorkspaceId -> Bool -> X ()
restart WorkspaceId
prog Bool
resume = do
    LayoutMessages -> X ()
forall a. Message a => a -> X ()
broadcastMessage LayoutMessages
ReleaseResources
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> (Display -> IO ()) -> Display -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> IO ()
flush (Display -> X ()) -> X Display -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
resume X ()
writeStateToFile
    IO () -> X ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (WorkspaceId
-> Bool
-> [WorkspaceId]
-> Maybe [(WorkspaceId, WorkspaceId)]
-> IO ()
forall a.
WorkspaceId
-> Bool
-> [WorkspaceId]
-> Maybe [(WorkspaceId, WorkspaceId)]
-> IO a
executeFile WorkspaceId
prog Bool
True [] Maybe [(WorkspaceId, WorkspaceId)]
forall a. Maybe a
Nothing)

------------------------------------------------------------------------
-- Floating layer support

-- | Given a window, find the screen it is located on, and compute
-- the geometry of that window WRT that screen.
floatLocation :: Window -> X (ScreenId, W.RationalRect)
floatLocation :: Pixel -> X (ScreenId, RationalRect)
floatLocation Pixel
w =
    X (ScreenId, RationalRect)
-> X (ScreenId, RationalRect) -> X (ScreenId, RationalRect)
forall a. X a -> X a -> X a
catchX X (ScreenId, RationalRect)
go (X (ScreenId, RationalRect) -> X (ScreenId, RationalRect))
-> X (ScreenId, RationalRect) -> X (ScreenId, RationalRect)
forall a b. (a -> b) -> a -> b
$ do
      -- Fallback solution if `go' fails.  Which it might, since it
      -- calls `getWindowAttributes'.
      Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
sc <- (XState
 -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> X (Screen
        WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState
  -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
 -> X (Screen
         WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
-> (XState
    -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> X (Screen
        WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
forall a b. (a -> b) -> a -> b
$ WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet
 -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> (XState -> WindowSet)
-> XState
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
      (ScreenId, RationalRect) -> X (ScreenId, RationalRect)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
sc, Rational -> Rational -> Rational -> Rational -> RationalRect
W.RationalRect Rational
0 Rational
0 Rational
1 Rational
1)

  where go :: X (ScreenId, RationalRect)
go = (Display -> X (ScreenId, RationalRect))
-> X (ScreenId, RationalRect)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (ScreenId, RationalRect))
 -> X (ScreenId, RationalRect))
-> (Display -> X (ScreenId, RationalRect))
-> X (ScreenId, RationalRect)
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
          WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
          SizeHints
sh <- IO SizeHints -> X SizeHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SizeHints -> X SizeHints) -> IO SizeHints -> X SizeHints
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO SizeHints
getWMNormalHints Display
d Pixel
w
          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 -> Pixel -> IO WindowAttributes
getWindowAttributes Display
d Pixel
w
          let bw :: Dimension
bw = (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Dimension)
-> (WindowAttributes -> CInt) -> WindowAttributes -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowAttributes -> CInt
wa_border_width) WindowAttributes
wa
          Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
point_sc <- Position
-> Position
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
pointScreen (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)
          Bool
managed <- Pixel -> X Bool
isClient Pixel
w

          -- ignore pointScreen for new windows unless it's the current
          -- screen, otherwise the float's relative size is computed against
          -- a different screen and the float ends up with the wrong size
          let sr_eq :: Maybe (Screen i l a sid ScreenDetail)
-> Maybe (Screen i l a sid ScreenDetail) -> Bool
sr_eq = Maybe Rectangle -> Maybe Rectangle -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe Rectangle -> Maybe Rectangle -> Bool)
-> (Maybe (Screen i l a sid ScreenDetail) -> Maybe Rectangle)
-> Maybe (Screen i l a sid ScreenDetail)
-> Maybe (Screen i l a sid ScreenDetail)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Screen i l a sid ScreenDetail -> Rectangle)
-> Maybe (Screen i l a sid ScreenDetail) -> Maybe Rectangle
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (Screen i l a sid ScreenDetail -> ScreenDetail)
-> Screen i l a sid ScreenDetail
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen i l a sid ScreenDetail -> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail)
              sc :: Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
sc = Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall a. a -> Maybe a -> a
fromMaybe (WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel 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 WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
 -> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall a b. (a -> b) -> a -> b
$
                  if Bool
managed Bool -> Bool -> Bool
|| Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
point_sc Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Bool
forall {i} {l} {a} {sid}.
Maybe (Screen i l a sid ScreenDetail)
-> Maybe (Screen i l a sid ScreenDetail) -> Bool
`sr_eq` Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
forall a. a -> Maybe a
Just (WindowSet
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws) then Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
point_sc else Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
forall a. Maybe a
Nothing
              sr :: Rectangle
sr = ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> ScreenDetail)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Rectangle)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Rectangle
forall a b. (a -> b) -> a -> b
$ Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
sc
              x :: Rational
x = (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (WindowAttributes -> CInt
wa_x WindowAttributes
wa) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
sr)) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
sr)
              y :: Rational
y = (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (WindowAttributes -> CInt
wa_y WindowAttributes
wa) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_y Rectangle
sr)) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
sr)
              (Dimension
width, Dimension
height) = SizeHints -> (CInt, CInt) -> (Dimension, Dimension)
forall a.
Integral a =>
SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHintsContents SizeHints
sh (WindowAttributes -> CInt
wa_width WindowAttributes
wa, WindowAttributes -> CInt
wa_height WindowAttributes
wa)
              rwidth :: Rational
rwidth  = Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Dimension
width Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
bwDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
*Dimension
2) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
sr)
              rheight :: Rational
rheight = Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Dimension
height Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
bwDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
*Dimension
2) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Dimension -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
sr)
              -- adjust x/y of unmanaged windows if we ignored or didn't get pointScreen,
              -- it might be out of bounds otherwise
              rr :: RationalRect
rr = if Bool
managed Bool -> Bool -> Bool
|| Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
point_sc Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> Bool
forall {i} {l} {a} {sid}.
Maybe (Screen i l a sid ScreenDetail)
-> Maybe (Screen i l a sid ScreenDetail) -> Bool
`sr_eq` Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
forall a. a -> Maybe a
Just Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
sc
                  then Rational -> Rational -> Rational -> Rational -> RationalRect
W.RationalRect Rational
x Rational
y Rational
rwidth Rational
rheight
                  else Rational -> Rational -> Rational -> Rational -> RationalRect
W.RationalRect (Rational
0.5 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
rwidthRational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
2) (Rational
0.5 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
rheightRational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
2) Rational
rwidth Rational
rheight

          (ScreenId, RationalRect) -> X (ScreenId, RationalRect)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
sc, RationalRect
rr)

        fi :: (Integral a, Num b) => a -> b
        fi :: forall a b. (Integral a, Num b) => a -> b
fi = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Given a point, determine the screen (if any) that contains it.
pointScreen :: Position -> Position
            -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail))
pointScreen :: Position
-> Position
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
pointScreen Position
x Position
y = (WindowSet
 -> X (Maybe
         (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)))
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet
  -> X (Maybe
          (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)))
 -> X (Maybe
         (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)))
-> (WindowSet
    -> X (Maybe
            (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)))
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
forall a b. (a -> b) -> a -> b
$ Maybe
  (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
   (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
 -> X (Maybe
         (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)))
-> (WindowSet
    -> Maybe
         (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
-> WindowSet
-> X (Maybe
        (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Bool)
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Bool
forall {i} {l} {a} {sid}. Screen i l a sid ScreenDetail -> Bool
p ([Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
 -> Maybe
      (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail))
-> (WindowSet
    -> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail])
-> WindowSet
-> Maybe
     (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.screens
  where p :: Screen i l a sid ScreenDetail -> Bool
p = Position -> Position -> Rectangle -> Bool
pointWithin Position
x Position
y (Rectangle -> Bool)
-> (Screen i l a sid ScreenDetail -> Rectangle)
-> Screen i l a sid ScreenDetail
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (Screen i l a sid ScreenDetail -> ScreenDetail)
-> Screen i l a sid ScreenDetail
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen i l a sid ScreenDetail -> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail

-- | @pointWithin x y r@ returns 'True' if the @(x, y)@ co-ordinate is within
-- @r@.
pointWithin :: Position -> Position -> Rectangle -> Bool
pointWithin :: Position -> Position -> Rectangle -> Bool
pointWithin Position
x Position
y Rectangle
r = Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Rectangle -> Position
rect_x Rectangle
r Bool -> Bool -> Bool
&&
                    Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<  Rectangle -> Position
rect_x Rectangle
r Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_width Rectangle
r) Bool -> Bool -> Bool
&&
                    Position
y Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Rectangle -> Position
rect_y Rectangle
r Bool -> Bool -> Bool
&&
                    Position
y Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<  Rectangle -> Position
rect_y Rectangle
r Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_height Rectangle
r)

-- | Make a tiled window floating, using its suggested rectangle
float :: Window -> X ()
float :: Pixel -> X ()
float Pixel
w = do
    (ScreenId
sc, RationalRect
rr) <- Pixel -> X (ScreenId, RationalRect)
floatLocation Pixel
w
    (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> Pixel -> RationalRect -> WindowSet -> WindowSet
forall a i l s sd.
Ord a =>
a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd
W.float Pixel
w RationalRect
rr (WindowSet -> WindowSet)
-> (Maybe WindowSet -> WindowSet) -> Maybe WindowSet -> WindowSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Maybe WindowSet -> WindowSet
forall a. a -> Maybe a -> a
fromMaybe WindowSet
ws (Maybe WindowSet -> WindowSet) -> Maybe WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ do
        WorkspaceId
i  <- Pixel -> WindowSet -> Maybe WorkspaceId
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Maybe i
W.findTag Pixel
w WindowSet
ws
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId
i WorkspaceId -> [WorkspaceId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
 -> WorkspaceId)
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
-> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId)
-> (Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Pixel) Pixel)
-> Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) (WindowSet
-> [Screen WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.screens WindowSet
ws)
        Pixel
f  <- WindowSet -> Maybe Pixel
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
ws
        WorkspaceId
sw <- ScreenId -> WindowSet -> Maybe WorkspaceId
forall s i l a sd. Eq s => s -> StackSet i l a s sd -> Maybe i
W.lookupWorkspace ScreenId
sc WindowSet
ws
        WindowSet -> Maybe WindowSet
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pixel -> 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 Pixel
f (WindowSet -> WindowSet)
-> (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceId -> Pixel -> 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 WorkspaceId
sw Pixel
w (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ WindowSet
ws)

-- ---------------------------------------------------------------------
-- Mouse handling

-- | Accumulate mouse motion events
mouseDrag :: (Position -> Position -> X ()) -> X () -> X ()
mouseDrag :: (Position -> Position -> X ()) -> X () -> X ()
mouseDrag = Maybe Glyph -> (Position -> Position -> X ()) -> X () -> X ()
mouseDragCursor Maybe Glyph
forall a. Maybe a
Nothing

-- | Like 'mouseDrag', but with the ability to specify a custom cursor
-- shape.
mouseDragCursor :: Maybe Glyph -> (Position -> Position -> X ()) -> X () -> X ()
mouseDragCursor :: Maybe Glyph -> (Position -> Position -> X ()) -> X () -> X ()
mouseDragCursor Maybe Glyph
cursorGlyph Position -> Position -> X ()
f X ()
done = do
    Maybe (Position -> Position -> X (), X ())
drag <- (XState -> Maybe (Position -> Position -> X (), X ()))
-> X (Maybe (Position -> Position -> X (), X ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> Maybe (Position -> Position -> X (), X ())
dragging
    case Maybe (Position -> Position -> X (), X ())
drag of
        Just (Position -> Position -> X (), X ())
_ -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- error case? we're already dragging
        Maybe (Position -> Position -> X (), X ())
Nothing -> do
            XConf { theRoot :: XConf -> Pixel
theRoot = Pixel
root, display :: XConf -> Display
display = Display
d } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
            IO CInt -> X CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO CInt -> X CInt) -> IO CInt -> X CInt
forall a b. (a -> b) -> a -> b
$ do Pixel
cursor <- IO Pixel -> (Glyph -> IO Pixel) -> Maybe Glyph -> IO Pixel
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Pixel -> IO Pixel
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pixel
none) (Display -> Glyph -> IO Pixel
createFontCursor Display
d) Maybe Glyph
cursorGlyph
                    Display
-> Pixel
-> Bool
-> Pixel
-> CInt
-> CInt
-> Pixel
-> Pixel
-> Pixel
-> IO CInt
grabPointer Display
d Pixel
root Bool
False (Pixel
buttonReleaseMask Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
pointerMotionMask)
                      CInt
grabModeAsync CInt
grabModeAsync Pixel
none Pixel
cursor Pixel
currentTime
            (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XState -> XState) -> X ()) -> (XState -> XState) -> X ()
forall a b. (a -> b) -> a -> b
$ \XState
s -> XState
s { dragging = Just (motion, cleanup) }
 where
    cleanup :: X ()
cleanup = do
        (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> (Display -> IO ()) -> Display -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Display -> Pixel -> IO ()) -> Pixel -> Display -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Display -> Pixel -> IO ()
ungrabPointer Pixel
currentTime
        (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XState -> XState) -> X ()) -> (XState -> XState) -> X ()
forall a b. (a -> b) -> a -> b
$ \XState
s -> XState
s { dragging = Nothing }
        X ()
done
    motion :: Position -> Position -> X ()
motion Position
x Position
y = do ()
z <- Position -> Position -> X ()
f Position
x Position
y
                    Pixel -> X ()
clearEvents Pixel
pointerMotionMask
                    () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
z

-- | Drag the window under the cursor with the mouse while it is dragged.
mouseMoveWindow :: Window -> X ()
mouseMoveWindow :: Pixel -> X ()
mouseMoveWindow Pixel
w = X Bool -> X () -> X ()
whenX (Pixel -> X Bool
isClient Pixel
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    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 -> Pixel -> IO WindowAttributes
getWindowAttributes Display
d Pixel
w
    (Bool
_, Pixel
_, Pixel
_, CInt
ox', CInt
oy', CInt
_, CInt
_, KeyMask
_) <- IO (Bool, Pixel, Pixel, CInt, CInt, CInt, CInt, KeyMask)
-> X (Bool, Pixel, Pixel, CInt, CInt, CInt, CInt, KeyMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Bool, Pixel, Pixel, CInt, CInt, CInt, CInt, KeyMask)
 -> X (Bool, Pixel, Pixel, CInt, CInt, CInt, CInt, KeyMask))
-> IO (Bool, Pixel, Pixel, CInt, CInt, CInt, CInt, KeyMask)
-> X (Bool, Pixel, Pixel, CInt, CInt, CInt, CInt, KeyMask)
forall a b. (a -> b) -> a -> b
$ Display
-> Pixel
-> IO (Bool, Pixel, Pixel, CInt, CInt, CInt, CInt, KeyMask)
queryPointer Display
d Pixel
w
    let ox :: Position
ox = CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ox'
        oy :: Position
oy = CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
oy'
    Maybe Glyph -> (Position -> Position -> X ()) -> X () -> X ()
mouseDragCursor
              (Glyph -> Maybe Glyph
forall a. a -> Maybe a
Just Glyph
xC_fleur)
              (\Position
ex Position
ey -> do
                  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Position -> Position -> IO ()
moveWindow Display
d Pixel
w (Position -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WindowAttributes -> CInt
wa_x WindowAttributes
wa) Position -> Position -> Position
forall a. Num a => a -> a -> a
+ (Position
ex Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
ox)))
                                      (Position -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WindowAttributes -> CInt
wa_y WindowAttributes
wa) Position -> Position -> Position
forall a. Num a => a -> a -> a
+ (Position
ey Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
oy)))
                  Pixel -> X ()
float Pixel
w
              )
              (Pixel -> X ()
float Pixel
w)

-- | Resize the window under the cursor with the mouse while it is dragged.
mouseResizeWindow :: Window -> X ()
mouseResizeWindow :: Pixel -> X ()
mouseResizeWindow Pixel
w = X Bool -> X () -> X ()
whenX (Pixel -> X Bool
isClient Pixel
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    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 -> Pixel -> IO WindowAttributes
getWindowAttributes Display
d Pixel
w
    SizeHints
sh <- IO SizeHints -> X SizeHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SizeHints -> X SizeHints) -> IO SizeHints -> X SizeHints
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO SizeHints
getWMNormalHints Display
d Pixel
w
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display
-> Pixel
-> Pixel
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
warpPointer Display
d Pixel
none Pixel
w Position
0 Position
0 Dimension
0 Dimension
0 (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WindowAttributes -> CInt
wa_width WindowAttributes
wa)) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WindowAttributes -> CInt
wa_height WindowAttributes
wa))
    Maybe Glyph -> (Position -> Position -> X ()) -> X () -> X ()
mouseDragCursor
              (Glyph -> Maybe Glyph
forall a. a -> Maybe a
Just Glyph
xC_bottom_right_corner)
              (\Position
ex Position
ey -> do
                 IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Dimension -> Dimension -> IO ()
resizeWindow Display
d Pixel
w (Dimension -> Dimension -> IO ())
-> (Dimension, Dimension) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
`uncurry`
                    SizeHints -> (Position, Position) -> (Dimension, Dimension)
forall a.
Integral a =>
SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHintsContents SizeHints
sh (Position
ex Position -> Position -> Position
forall a. Num a => a -> a -> a
- CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WindowAttributes -> CInt
wa_x WindowAttributes
wa),
                                               Position
ey Position -> Position -> Position
forall a. Num a => a -> a -> a
- CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WindowAttributes -> CInt
wa_y WindowAttributes
wa))
                 Pixel -> X ()
float Pixel
w)
              (Pixel -> X ()
float Pixel
w)

-- ---------------------------------------------------------------------
-- Support for window size hints

-- | An alias for a (width, height) pair
type D = (Dimension, Dimension)

-- | Given a window, build an adjuster function that will reduce the given
-- dimensions according to the window's border width and size hints.
mkAdjust :: Window -> X (D -> D)
mkAdjust :: Pixel -> X ((Dimension, Dimension) -> (Dimension, Dimension))
mkAdjust Pixel
w = (Display -> X ((Dimension, Dimension) -> (Dimension, Dimension)))
-> X ((Dimension, Dimension) -> (Dimension, Dimension))
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ((Dimension, Dimension) -> (Dimension, Dimension)))
 -> X ((Dimension, Dimension) -> (Dimension, Dimension)))
-> (Display
    -> X ((Dimension, Dimension) -> (Dimension, Dimension)))
-> X ((Dimension, Dimension) -> (Dimension, Dimension))
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO ((Dimension, Dimension) -> (Dimension, Dimension))
-> X ((Dimension, Dimension) -> (Dimension, Dimension))
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((Dimension, Dimension) -> (Dimension, Dimension))
 -> X ((Dimension, Dimension) -> (Dimension, Dimension)))
-> IO ((Dimension, Dimension) -> (Dimension, Dimension))
-> X ((Dimension, Dimension) -> (Dimension, Dimension))
forall a b. (a -> b) -> a -> b
$ do
    SizeHints
sh <- Display -> Pixel -> IO SizeHints
getWMNormalHints Display
d Pixel
w
    Either SomeException WindowAttributes
wa <- IO WindowAttributes -> IO (Either SomeException WindowAttributes)
forall e a. Exception e => IO a -> IO (Either e a)
C.try (IO WindowAttributes -> IO (Either SomeException WindowAttributes))
-> IO WindowAttributes
-> IO (Either SomeException WindowAttributes)
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO WindowAttributes
getWindowAttributes Display
d Pixel
w
    case Either SomeException WindowAttributes
wa of
         Left (SomeException
_ :: C.SomeException) -> ((Dimension, Dimension) -> (Dimension, Dimension))
-> IO ((Dimension, Dimension) -> (Dimension, Dimension))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dimension, Dimension) -> (Dimension, Dimension)
forall a. a -> a
id
         Right WindowAttributes
wa' ->
            let bw :: Dimension
bw = CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_border_width WindowAttributes
wa'
            in  ((Dimension, Dimension) -> (Dimension, Dimension))
-> IO ((Dimension, Dimension) -> (Dimension, Dimension))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Dimension, Dimension) -> (Dimension, Dimension))
 -> IO ((Dimension, Dimension) -> (Dimension, Dimension)))
-> ((Dimension, Dimension) -> (Dimension, Dimension))
-> IO ((Dimension, Dimension) -> (Dimension, Dimension))
forall a b. (a -> b) -> a -> b
$ Dimension
-> SizeHints -> (Dimension, Dimension) -> (Dimension, Dimension)
forall a.
Integral a =>
Dimension -> SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHints Dimension
bw SizeHints
sh

-- | Reduce the dimensions if needed to comply to the given SizeHints, taking
-- window borders into account.
applySizeHints :: Integral a => Dimension -> SizeHints -> (a, a) -> D
applySizeHints :: forall a.
Integral a =>
Dimension -> SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHints Dimension
bw SizeHints
sh =
    (Dimension -> Dimension)
-> (Dimension, Dimension) -> (Dimension, Dimension)
forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
tmap (Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
2 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
bw) ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((a, a) -> (Dimension, Dimension))
-> (a, a)
-> (Dimension, Dimension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SizeHints -> (a, a) -> (Dimension, Dimension)
forall a.
Integral a =>
SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHintsContents SizeHints
sh ((a, a) -> (Dimension, Dimension))
-> ((a, a) -> (a, a)) -> (a, a) -> (Dimension, Dimension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> (a, a) -> (a, a)
forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
tmap (a -> a -> a
forall a. Num a => a -> a -> a
subtract (a -> a -> a) -> a -> a -> a
forall a b. (a -> b) -> a -> b
$ a
2 a -> a -> a
forall a. Num a => a -> a -> a
* Dimension -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
bw)
    where
    tmap :: (t -> b) -> (t, t) -> (b, b)
tmap t -> b
f (t
x, t
y) = (t -> b
f t
x, t -> b
f t
y)

-- | Reduce the dimensions if needed to comply to the given SizeHints.
applySizeHintsContents :: Integral a => SizeHints -> (a, a) -> D
applySizeHintsContents :: forall a.
Integral a =>
SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHintsContents SizeHints
sh (a
w, a
h) =
    SizeHints -> (Dimension, Dimension) -> (Dimension, Dimension)
applySizeHints' SizeHints
sh (a -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Dimension) -> a -> Dimension
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Ord a => a -> a -> a
max a
1 a
w, a -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Dimension) -> a -> Dimension
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Ord a => a -> a -> a
max a
1 a
h)

-- | Use X11 size hints to scale a pair of dimensions.
applySizeHints' :: SizeHints -> D -> D
applySizeHints' :: SizeHints -> (Dimension, Dimension) -> (Dimension, Dimension)
applySizeHints' SizeHints
sh =
      ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension)
    -> (Dimension, Dimension) -> (Dimension, Dimension))
-> Maybe (Dimension, Dimension)
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Dimension, Dimension) -> (Dimension, Dimension)
forall a. a -> a
id (Dimension, Dimension)
-> (Dimension, Dimension) -> (Dimension, Dimension)
applyMaxSizeHint                   (SizeHints -> Maybe (Dimension, Dimension)
sh_max_size   SizeHints
sh)
    ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension) -> (Dimension, Dimension))
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension)
    -> (Dimension, Dimension) -> (Dimension, Dimension))
-> Maybe (Dimension, Dimension)
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Dimension, Dimension) -> (Dimension, Dimension)
forall a. a -> a
id (\(Dimension
bw, Dimension
bh) (Dimension
w, Dimension
h) -> (Dimension
wDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Dimension
bw, Dimension
hDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Dimension
bh)) (SizeHints -> Maybe (Dimension, Dimension)
sh_base_size  SizeHints
sh)
    ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension) -> (Dimension, Dimension))
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension)
    -> (Dimension, Dimension) -> (Dimension, Dimension))
-> Maybe (Dimension, Dimension)
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Dimension, Dimension) -> (Dimension, Dimension)
forall a. a -> a
id (Dimension, Dimension)
-> (Dimension, Dimension) -> (Dimension, Dimension)
applyResizeIncHint                 (SizeHints -> Maybe (Dimension, Dimension)
sh_resize_inc SizeHints
sh)
    ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension) -> (Dimension, Dimension))
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Dimension, Dimension) -> (Dimension, Dimension))
-> (((Dimension, Dimension), (Dimension, Dimension))
    -> (Dimension, Dimension) -> (Dimension, Dimension))
-> Maybe ((Dimension, Dimension), (Dimension, Dimension))
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Dimension, Dimension) -> (Dimension, Dimension)
forall a. a -> a
id ((Dimension, Dimension), (Dimension, Dimension))
-> (Dimension, Dimension) -> (Dimension, Dimension)
applyAspectHint                    (SizeHints -> Maybe ((Dimension, Dimension), (Dimension, Dimension))
sh_aspect     SizeHints
sh)
    ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension) -> (Dimension, Dimension))
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Dimension, Dimension) -> (Dimension, Dimension))
-> ((Dimension, Dimension)
    -> (Dimension, Dimension) -> (Dimension, Dimension))
-> Maybe (Dimension, Dimension)
-> (Dimension, Dimension)
-> (Dimension, Dimension)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Dimension, Dimension) -> (Dimension, Dimension)
forall a. a -> a
id (\(Dimension
bw,Dimension
bh) (Dimension
w,Dimension
h)   -> (Dimension
wDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
-Dimension
bw, Dimension
hDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
-Dimension
bh)) (SizeHints -> Maybe (Dimension, Dimension)
sh_base_size  SizeHints
sh)

-- | Reduce the dimensions so their aspect ratio falls between the two given aspect ratios.
applyAspectHint :: (D, D) -> D -> D
applyAspectHint :: ((Dimension, Dimension), (Dimension, Dimension))
-> (Dimension, Dimension) -> (Dimension, Dimension)
applyAspectHint ((Dimension
minx, Dimension
miny), (Dimension
maxx, Dimension
maxy)) x :: (Dimension, Dimension)
x@(Dimension
w,Dimension
h)
    | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Dimension
minx Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
1, Dimension
miny Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
1, Dimension
maxx Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
1, Dimension
maxy Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
1] = (Dimension, Dimension)
x
    | Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
maxy Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
maxx                         = (Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
maxx Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
maxy, Dimension
h)
    | Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
miny Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
minx                         = (Dimension
w, Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
miny Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
minx)
    | Bool
otherwise                                   = (Dimension, Dimension)
x

-- | Reduce the dimensions so they are a multiple of the size increments.
applyResizeIncHint :: D -> D -> D
applyResizeIncHint :: (Dimension, Dimension)
-> (Dimension, Dimension) -> (Dimension, Dimension)
applyResizeIncHint (Dimension
iw,Dimension
ih) x :: (Dimension, Dimension)
x@(Dimension
w,Dimension
h) =
    if Dimension
iw Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension
0 Bool -> Bool -> Bool
&& Dimension
ih Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension
0 then (Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
w Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`mod` Dimension
iw, Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
h Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`mod` Dimension
ih) else (Dimension, Dimension)
x

-- | Reduce the dimensions if they exceed the given maximum dimensions.
applyMaxSizeHint  :: D -> D -> D
applyMaxSizeHint :: (Dimension, Dimension)
-> (Dimension, Dimension) -> (Dimension, Dimension)
applyMaxSizeHint (Dimension
mw,Dimension
mh) x :: (Dimension, Dimension)
x@(Dimension
w,Dimension
h) =
    if Dimension
mw Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension
0 Bool -> Bool -> Bool
&& Dimension
mh Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension
0 then (Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min Dimension
w Dimension
mw,Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min Dimension
h Dimension
mh) else (Dimension, Dimension)
x