Rename XMonad to MetaTile

1 files changed, 588 insertions, 0 deletions

diff --git a/MetaTile/Operations.hs b/MetaTile/Operations.hs
new file mode 100644
index 0000000..1a2fd11
--- /dev/null
+++ b/MetaTile/Operations.hs
@@ -0,0 +1,588 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
+
+-- --------------------------------------------------------------------------
+-- |
+-- Module      :  MetaTile.Operations
+-- Copyright   :  (c) Spencer Janssen 2007
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  dons@cse.unsw.edu.au
+-- Stability   :  unstable
+-- Portability :  not portable, Typeable deriving, mtl, posix
+--
+-- Operations.
+--
+-----------------------------------------------------------------------------
+
+module MetaTile.Operations where
+
+import MetaTile.Core
+import MetaTile.Layout (Full(..))
+import qualified MetaTile.StackSet as W
+
+import Data.Maybe
+import Data.Monoid          (Endo(..))
+import Data.List            (nub, (\\), find)
+import Data.Bits            ((.|.), (.&.), complement, testBit)
+import Data.Ratio
+import qualified Data.Map as M
+
+import Control.Applicative
+import Control.Arrow ((&&&))
+import Control.Monad.Reader
+import Control.Monad.State
+import qualified Control.Exception.Extensible as C
+
+import System.Posix.Process (executeFile)
+import Graphics.X11.Xlib
+import Graphics.X11.Xinerama (getScreenInfo)
+import Graphics.X11.Xlib.Extras
+
+-- ---------------------------------------------------------------------
+-- |
+-- Window manager operations
+-- manage. 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 w = whenX (not <$> isClient w) $ do
+    mh <- asks (manageHook . config)
+    g <- appEndo <$> userCodeDef (Endo id) (runQuery mh w)
+    windows (g . W.insertUp w)
+
+-- | unmanage. A window no longer exists, remove it from the window
+-- list, on whatever workspace it is.
+--
+unmanage :: Window -> X ()
+unmanage = windows . 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 w = withDisplay $ \d -> do
+    wmdelt <- atom_WM_DELETE_WINDOW  ;  wmprot <- atom_WM_PROTOCOLS
+
+    protocols <- io $ getWMProtocols d w
+    io $ if wmdelt `elem` protocols
+        then allocaXEvent $ \ev -> do
+                setEventType ev clientMessage
+                setClientMessageEvent ev w wmprot 32 wmdelt 0
+                sendEvent d w False noEventMask ev
+        else killClient d w >> return ()
+
+-- | Kill the currently focused client.
+kill :: X ()
+kill = withFocused killWindow
+
+-- ---------------------------------------------------------------------
+-- Managing windows
+
+-- | windows. Modify the current window list with a pure function, and refresh
+windows :: (WindowSet -> WindowSet) -> X ()
+windows f = do
+    XState { windowset = old } <- get
+    let oldvisible = concatMap (W.integrate' . W.stack . W.screenWorkspace) $ W.screens old
+        newwindows = W.allWindows ws \\ W.allWindows old
+        ws = f old
+    XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask
+
+    mapM_ setInitialProperties newwindows
+
+    whenJust (W.peek old) $ \otherw -> setFrameBackground d otherw nbc
+    modify (\s -> s { windowset = ws })
+
+    -- notify non visibility
+    let tags_oldvisible = map (W.tag . W.screenWorkspace) $ W.screens old
+        gottenhidden    = filter (flip elem tags_oldvisible . W.tag) $ W.hidden ws
+    mapM_ (sendMessageWithNoRefresh Hide) gottenhidden
+
+    -- for each workspace, layout the currently visible workspaces
+    let allscreens     = W.screens ws
+        summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.screenWorkspace) allscreens
+    rects <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do
+        let wsp   = W.screenWorkspace w
+            this  = W.view n ws
+            n     = W.tag wsp
+            tiled = (W.stack . W.screenWorkspace . W.current $ this)
+                    >>= W.filter (`notElem` vis)
+            viewrect = screenRect $ W.screenDetail w
+
+        -- just the tiled windows:
+        -- now tile the windows on this workspace, modified by the gap
+        (rs, ml') <- runLayout wsp { W.stack = tiled } viewrect `catchX`
+                     runLayout wsp { W.stack = tiled, W.layout = Layout Full } viewrect
+        updateLayout n ml'
+
+        io $ restackWindows d (map fst rs)
+        -- return the visible windows for this workspace:
+        return rs
+
+    let visible = map fst rects
+
+    mapM_ (uncurry tileWindow) rects
+
+    whenJust (W.peek ws) $ \w -> setFrameBackground d w fbc
+
+    mapM_ reveal visible
+    setTopFocus
+
+    -- hide every window that was potentially visible before, but is not
+    -- given a position by a layout now.
+    mapM_ hide (nub (oldvisible ++ newwindows) \\ 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
+    mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws)
+
+    isMouseFocused <- asks mouseFocused
+    unless isMouseFocused $ clearEvents enterWindowMask
+    asks (logHook . config) >>= userCodeDef ()
+  where
+    setFrameBackground :: Display -> Window -> Pixel -> X ()
+    setFrameBackground d w p = do
+      frame <- getsWindowState wsFrame w
+      io $ do
+        setWindowBackground d frame p
+        clearWindow d frame
+
+-- | Produce the actual rectangle from a screen and a ratio on that screen.
+scaleRationalRect :: Rectangle -> W.RationalRect -> Rectangle
+scaleRationalRect (Rectangle sx sy sw sh) (W.RationalRect rx ry rw rh)
+ = Rectangle (sx + scale sw rx) (sy + scale sh ry) (scale sw rw) (scale sh rh)
+ where scale s r = floor (toRational s * r)
+
+-- | setWMState.  set the WM_STATE property
+setWMState :: Window -> Int -> X ()
+setWMState w v = withDisplay $ \dpy -> do
+    a <- atom_WM_STATE
+    io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none]
+
+-- | hide. Hide a window by unmapping it, and setting Iconified.
+hide :: Window -> X ()
+hide w = whenX (getsWindowState wsMapped w) $ withDisplay $ \d -> do
+    (cMask,fMask) <- asks $ (clientMask &&& frameMask) . config
+    frame <- getsWindowState wsFrame w
+    io $ do selectInput d w (cMask .&. complement structureNotifyMask)
+            selectInput d frame (fMask .&. complement structureNotifyMask)
+            unmapWindow d frame
+            selectInput d frame fMask
+            selectInput d w cMask
+    setWMState w iconicState
+    -- this part is key: we increment the waitingUnmap counter to distinguish
+    -- between client and xmonad initiated unmaps.
+    modifyWindowState (\ws -> ws { wsMapped       = False
+                                 , wsWaitingUnmap = (wsWaitingUnmap ws) + 1 }) w
+
+configureClientWindow :: Window -> X ()
+configureClientWindow w = withDisplay $ \d -> do
+    (frame, bw) <- getsWindowState (wsFrame &&& wsBorderWidth) w
+    (_, x, y, width, height, _, _) <- io $ getGeometry d frame
+    let least1 n = max 1 n
+        x' = x + (fi $ bwLeft bw)
+        y' = y + (fi $ bwTop bw)
+        width' = least1 (width - bwLeft bw - bwRight bw)
+        height' = least1 (height - bwTop bw - bwBottom bw)
+    io $ do
+        moveResizeWindow d w (fi $ bwLeft bw) (fi $ bwTop bw) width' height'
+        -- send absolute ConfigureNotify
+        allocaXEvent $ \event -> do
+            setEventType event configureNotify
+            setConfigureEvent event w w (fi x') (fi y') (fi width') (fi height') 0 none False
+            sendEvent d w False 0 event
+  where
+    fi :: (Integral a, Num b) => a -> b
+    fi = fromIntegral
+
+-- | reveal. Show a window by mapping it and setting Normal
+-- this is harmless if the window was already visible
+reveal :: Window -> X ()
+reveal w = withDisplay $ \d -> do
+    setWMState w normalState
+    io $ mapWindow d w
+    whenX (isClient w) $ do
+        configureClientWindow w
+        getsWindowState wsFrame w >>= io . mapWindow d
+        modifyWindowState (\ws -> ws { wsMapped = True }) w
+
+-- | Set some properties when we initially gain control of a window
+setInitialProperties :: Window -> X ()
+setInitialProperties w = withDisplay $ \d -> do
+    setWMState w iconicState
+    asks (clientMask . config) >>= io . selectInput d w
+    io $ setWindowBorderWidth d w 0
+
+-- | refresh. 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 = windows id
+
+-- | clearEvents.  Remove all events of a given type from the event queue.
+clearEvents :: EventMask -> X ()
+clearEvents mask = withDisplay $ \d -> io $ do
+    sync d False
+    allocaXEvent $ \p -> fix $ \again -> do
+        more <- checkMaskEvent d mask p
+        when more again -- beautiful
+
+-- | tileWindow. Moves and resizes w such that it fits inside the given
+-- rectangle, including its border.
+tileWindow :: Window -> Rectangle -> X ()
+tileWindow w r = withDisplay $ \d -> do
+    -- give all windows at least 1x1 pixels
+    let least x | x <= 0  = 1
+                | otherwise  = x
+    frame <- getsWindowState wsFrame w
+    io $ moveResizeWindow d frame (rect_x r) (rect_y r) (least $ rect_width r) (least $ rect_height r)
+
+-- ---------------------------------------------------------------------
+
+-- | Returns 'True' if the first rectangle is contained within, but not equal
+-- to the second.
+containedIn :: Rectangle -> Rectangle -> Bool
+containedIn r1@(Rectangle x1 y1 w1 h1) r2@(Rectangle x2 y2 w2 h2)
+ = and [ r1 /= r2
+       , x1 >= x2
+       , y1 >= y2
+       , fromIntegral x1 + w1 <= fromIntegral x2 + w2
+       , fromIntegral y1 + h1 <= fromIntegral y2 + h2 ]
+
+-- | Given a list of screens, remove all duplicated screens and screens that
+-- are entirely contained within another.
+nubScreens :: [Rectangle] -> [Rectangle]
+nubScreens xs = nub . filter (\x -> not $ any (x `containedIn`) xs) $ xs
+
+-- | Cleans the list of screens according to the rules documented for
+-- nubScreens.
+getCleanedScreenInfo :: MonadIO m => Display -> m [Rectangle]
+getCleanedScreenInfo = io .  fmap nubScreens . getScreenInfo
+
+-- | rescreen.  The screen configuration may have changed (due to
+-- xrandr), update the state and refresh the screen, and reset the gap.
+rescreen :: X ()
+rescreen = do
+    xinesc <- withDisplay getCleanedScreenInfo
+
+    windows $ \ws ->
+        let (xs, ys) = splitAt (length xinesc) $ W.workspaces ws
+            (a:as)   = zipWith3 (flip W.Screen []) xs [0..] $ map SD xinesc
+        in  ws { W.current = a { W.screenHidden = ys }
+               , W.visible = as }
+
+-- ---------------------------------------------------------------------
+
+-- | setButtonGrab. Tell whether or not to intercept clicks on a given window
+setButtonGrab :: Bool -> Window -> X ()
+setButtonGrab grab w = do
+    pointerMode <- asks $ \c -> if clickJustFocuses (config c)
+                                    then grabModeAsync
+                                    else grabModeSync
+    withDisplay $ \d -> io $ if grab
+        then forM_ [button1, button2, button3] $ \b ->
+            grabButton d b anyModifier w False buttonPressMask
+                       pointerMode grabModeSync none none
+        else ungrabButton d anyButton anyModifier w
+
+-- ---------------------------------------------------------------------
+-- Setting keyboard focus
+
+-- | Set the focus to the window on top of the stack, or root
+setTopFocus :: X ()
+setTopFocus = withWindowSet $ maybe (setFocusX =<< asks theRoot) setFocusX . 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 w = local (\c -> c { mouseFocused = True }) $ withWindowSet $ \s -> do
+    let stag = W.tag . W.screenWorkspace
+        curr = stag $ W.current s
+    mnew <- maybe (return Nothing) (fmap (fmap stag) . uncurry pointScreen)
+            =<< asks mousePosition
+    root <- asks theRoot
+    case () of
+        _ | W.member w s && W.peek s /= Just w -> windows (W.focusWindow w)
+          | Just new <- mnew, w == root && curr /= new
+                                               -> windows (W.view new)
+          | otherwise                          -> return ()
+
+-- | Call X to set the keyboard focus details.
+setFocusX :: Window -> X ()
+setFocusX w = withWindowSet $ \ws -> do
+    dpy <- asks display
+
+    -- clear mouse button grab and border on other windows
+    forM_ (W.screens ws) $ \wk ->
+      forM_ (W.index (W.view (W.tag (W.screenWorkspace wk)) ws)) $ \otherw ->
+        setButtonGrab True otherw
+
+    -- If we ungrab buttons on the root window, we lose our mouse bindings.
+    whenX (not <$> isRoot w) $ setButtonGrab False w
+
+    hints <- io $ getWMHints dpy w
+    protocols <- io $ getWMProtocols dpy w
+    wmprot <- atom_WM_PROTOCOLS
+    wmtf <- atom_WM_TAKE_FOCUS
+    currevt <- asks currentEvent
+    let inputHintSet = wmh_flags hints `testBit` inputHintBit
+
+    when ((inputHintSet && wmh_input hints) || (not inputHintSet)) $
+      io $ do setInputFocus dpy w revertToPointerRoot 0
+    when (wmtf `elem` protocols) $
+      io $ allocaXEvent $ \ev -> do
+        setEventType ev clientMessage
+        setClientMessageEvent ev w wmprot 32 wmtf $ maybe currentTime event_time currevt
+        sendEvent dpy w False noEventMask ev
+        where event_time ev =
+                if (ev_event_type ev) `elem` timedEvents then
+                  ev_time ev
+                else
+                  currentTime
+              timedEvents = [ keyPress, keyRelease, buttonPress, buttonRelease, enterNotify, leaveNotify, selectionRequest ]
+
+------------------------------------------------------------------------
+-- Message handling
+
+-- | Throw a message to the current 'LayoutClass' possibly modifying how we
+-- layout the windows, then refresh.
+sendMessage :: Message a => a -> X ()
+sendMessage a = do
+    w <- W.screenWorkspace . W.current <$> gets windowset
+    ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
+    whenJust ml' $ \l' ->
+        windows $ \ws -> ws { W.current = (W.current ws)
+                                { W.screenWorkspace = (W.screenWorkspace $ W.current ws)
+                                  { W.layout = l' }}}
+
+-- | Send a message to all layouts, without refreshing.
+broadcastMessage :: Message a => a -> X ()
+broadcastMessage a = withWindowSet $ \ws ->
+   mapM_ (sendMessageWithNoRefresh a) (W.workspaces ws)
+
+-- | Send a message to a layout, without refreshing.
+sendMessageWithNoRefresh :: Message a => a -> W.Workspace WorkspaceId (Layout Window) Window -> X ()
+sendMessageWithNoRefresh a w =
+    handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>=
+    updateLayout  (W.tag w)
+
+-- | Update the layout field of a workspace
+updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X ()
+updateLayout i ml = whenJust ml $ \l ->
+    runOnWorkspaces $ \ww -> return $ if W.tag ww == i then ww { W.layout = l} else ww
+
+-- | Set the layout of the currently viewed workspace
+setLayout :: Layout Window -> X ()
+setLayout l = do
+    ss@(W.StackSet { W.current = c@(W.Screen { W.screenWorkspace = ws })}) <- gets windowset
+    handleMessage (W.layout ws) (SomeMessage ReleaseResources)
+    windows $ const $ ss {W.current = c { W.screenWorkspace = ws { W.layout = l } } }
+
+------------------------------------------------------------------------
+-- Utilities
+
+-- | Return workspace visible on screen 'sc', or 'Nothing'.
+screenWorkspace :: ScreenId -> X (Maybe WorkspaceId)
+screenWorkspace sc = withWindowSet $ return . W.lookupWorkspace sc
+
+-- | Apply an 'X' operation to the currently focused window, if there is one.
+withFocused :: (Window -> X ()) -> X ()
+withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f
+
+-- | 'True' if window is under management by us
+isClient :: Window -> X Bool
+isClient w = withWindowSet $ return . W.member w
+
+-- | Combinations of extra modifier masks we need to grab keys\/buttons for.
+-- (numlock and capslock)
+extraModifiers :: X [KeyMask]
+extraModifiers = do
+    nlm <- gets numberlockMask
+    return [0, nlm, lockMask, nlm .|. lockMask ]
+
+-- | Strip numlock\/capslock from a mask
+cleanMask :: KeyMask -> X KeyMask
+cleanMask km = do
+    nlm <- gets numberlockMask
+    return (complement (nlm .|. lockMask) .&. km)
+
+-- | Get the 'Pixel' value for a named color
+initColor :: Display -> String -> IO (Maybe Pixel)
+initColor dpy c = C.handle (\(C.SomeException _) -> return Nothing) $
+    (Just . color_pixel . fst) <$> allocNamedColor dpy colormap c
+    where colormap = defaultColormap dpy (defaultScreen dpy)
+
+------------------------------------------------------------------------
+
+-- | @restart name resume@. Attempt 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 prog resume = do
+    broadcastMessage ReleaseResources
+    io . flush =<< asks display
+    let wsData = show . W.mapLayout show . windowset
+        maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext)
+        maybeShow (t, Left str) = Just (t, str)
+        maybeShow _ = Nothing
+        extState = return . show . catMaybes . map maybeShow . M.toList . extensibleState
+    args <- if resume then gets (\s -> "--resume":wsData s:extState s) else return []
+    catchIO (executeFile prog True args 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 w = withDisplay $ \d -> do
+    ws <- gets windowset
+    wa <- io $ getWindowAttributes d w
+    let bw = (fromIntegral . wa_border_width) wa
+    sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa)
+
+    let sr = screenRect . W.screenDetail $ sc
+        rr = W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr))
+                            ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr))
+                            (fi (wa_width  wa + bw*2) % fi (rect_width sr))
+                            (fi (wa_height wa + bw*2) % fi (rect_height sr))
+
+    return (W.screen sc, rr)
+  where fi x = fromIntegral x
+
+-- | 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 x y = withWindowSet $ return . find p . W.screens
+  where p = pointWithin x y . screenRect . W.screenDetail
+
+-- | @pointWithin x y r@ returns 'True' if the @(x, y)@ co-ordinate is within
+-- @r@.
+pointWithin :: Position -> Position -> Rectangle -> Bool
+pointWithin x y r = x >= rect_x r &&
+                    x <  rect_x r + fromIntegral (rect_width r) &&
+                    y >= rect_y r &&
+                    y <  rect_y r + fromIntegral (rect_height r)
+
+-- | Make a tiled window floating, using its suggested rectangle
+{-float :: Window -> X ()
+float w = do
+    (sc, rr) <- floatLocation w
+    windows $ \ws -> W.float w rr . fromMaybe ws $ do
+        i  <- W.findTag w ws
+        guard $ i `elem` concatMap (map W.tag . W.screenWorkspaces) (W.screens ws)
+        f  <- W.peek ws
+        sw <- W.lookupWorkspace sc ws
+        return (W.focusWindow f . W.shiftWin sw w $ ws)-}
+
+-- ---------------------------------------------------------------------
+-- Mouse handling
+
+-- | Accumulate mouse motion events
+mouseDrag :: (Position -> Position -> X ()) -> X () -> X ()
+mouseDrag f done = do
+    drag <- gets dragging
+    case drag of
+        Just _ -> return () -- error case? we're already dragging
+        Nothing -> do
+            XConf { theRoot = root, display = d } <- ask
+            io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask)
+                    grabModeAsync grabModeAsync none none currentTime
+            modify $ \s -> s { dragging = Just (motion, cleanup) }
+ where
+    cleanup = do
+        withDisplay $ io . flip ungrabPointer currentTime
+        modify $ \s -> s { dragging = Nothing }
+        done
+    motion x y = do z <- f x y
+                    clearEvents pointerMotionMask
+                    return z
+
+-- | XXX comment me
+{-mouseMoveWindow :: Window -> X ()
+mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do
+    io $ raiseWindow d w
+    wa <- io $ getWindowAttributes d w
+    (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w
+    let ox = fromIntegral ox'
+        oy = fromIntegral oy'
+    mouseDrag (\ex ey -> io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
+                                             (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))))
+              (float w)
+
+-- | XXX comment me
+mouseResizeWindow :: Window -> X ()
+mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
+    io $ raiseWindow d w
+    wa <- io $ getWindowAttributes d w
+    sh <- io $ getWMNormalHints d w
+    io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa))
+    mouseDrag (\ex ey ->
+                 io $ resizeWindow d w `uncurry`
+                    applySizeHintsContents sh (ex - fromIntegral (wa_x wa),
+                                               ey - fromIntegral (wa_y wa)))
+              (float w)-}
+
+-- ---------------------------------------------------------------------
+-- | Support for window size hints
+
+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 w = withDisplay $ \d -> liftIO $ do
+    sh <- getWMNormalHints d w
+    bw <- fmap (fromIntegral . wa_border_width) $ getWindowAttributes d w
+    return $ applySizeHints bw 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 bw sh =
+    tmap (+ 2 * bw) . applySizeHintsContents sh . tmap (subtract $ 2 * fromIntegral bw)
+    where
+    tmap f (x, y) = (f x, f y)
+
+-- | Reduce the dimensions if needed to comply to the given SizeHints.
+applySizeHintsContents :: Integral a => SizeHints -> (a, a) -> D
+applySizeHintsContents sh (w, h) =
+    applySizeHints' sh (fromIntegral $ max 1 w, fromIntegral $ max 1 h)
+
+-- | XXX comment me
+applySizeHints' :: SizeHints -> D -> D
+applySizeHints' sh =
+      maybe id applyMaxSizeHint                   (sh_max_size   sh)
+    . maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size  sh)
+    . maybe id applyResizeIncHint                 (sh_resize_inc sh)
+    . maybe id applyAspectHint                    (sh_aspect     sh)
+    . maybe id (\(bw,bh) (w,h)   -> (w-bw, h-bh)) (sh_base_size  sh)
+
+-- | Reduce the dimensions so their aspect ratio falls between the two given aspect ratios.
+applyAspectHint :: (D, D) -> D -> D
+applyAspectHint ((minx, miny), (maxx, maxy)) x@(w,h)
+    | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = x
+    | w * maxy > h * maxx                         = (h * maxx `div` maxy, h)
+    | w * miny < h * minx                         = (w, w * miny `div` minx)
+    | otherwise                                   = x
+
+-- | Reduce the dimensions so they are a multiple of the size increments.
+applyResizeIncHint :: D -> D -> D
+applyResizeIncHint (iw,ih) x@(w,h) =
+    if iw > 0 && ih > 0 then (w - w `mod` iw, h - h `mod` ih) else x
+
+-- | Reduce the dimensions if they exceed the given maximum dimensions.
+applyMaxSizeHint  :: D -> D -> D
+applyMaxSizeHint (mw,mh) x@(w,h) =
+    if mw > 0 && mh > 0 then (min w mw,min h mh) else x