content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
  
  -- --------------------------------------------------------------------------
  -- |
  -- Module      :  XMonad.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 XMonad.Operations where
  
  import XMonad.Core
  import XMonad.Layout (Full(..))
  import qualified XMonad.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 qualified Data.Set as S
  
  import Control.Applicative
  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) $ withDisplay $ \d -> do
      sh <- io $ getWMNormalHints d w
  
      let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh
      isTransient <- isJust <$> io (getTransientForHint d w)
  
      rr <- snd `fmap` floatLocation w
      -- ensure that float windows don't go over the edge of the screen
      let adjust (W.RationalRect x y wid h) | x + wid > 1 || y + h > 1 || x < 0 || y < 0
                                                = W.RationalRect (0.5 - wid/2) (0.5 - h/2) wid h
          adjust r = r
  
          f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws
               | otherwise                  = W.insertUp w ws
              where i = W.tag $ W.workspace $ W.current ws
  
      mh <- asks (manageHook . config)
      g <- appEndo <$> userCodeDef (Endo id) (runQuery mh w)
      windows (g . f)
  
  -- | 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.workspace) $ W.current old : W.visible 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 -> io $ setWindowBorder d otherw nbc
      modify (\s -> s { windowset = ws })
  
      -- notify non visibility
      let tags_oldvisible = map (W.tag . W.workspace) $ W.current old : W.visible 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.workspace) allscreens
      rects <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do
          let wsp   = W.workspace w
              this  = W.view n ws
              n     = W.tag wsp
              tiled = (W.stack . W.workspace . W.current $ this)
                      >>= W.filter (`M.notMember` W.floating ws)
                      >>= 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'
  
          let m   = W.floating ws
              flt = [(fw, scaleRationalRect viewrect r)
                      | fw <- filter (flip M.member m) (W.index this)
                      , Just r <- [M.lookup fw m]]
              vs = flt ++ rs
  
          io $ restackWindows d (map fst vs)
          -- return the visible windows for this workspace:
          return vs
  
      let visible = map fst rects
  
      mapM_ (uncurry tileWindow) rects
  
      whenJust (W.peek ws) $ \w -> io $ setWindowBorder 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 ()
  
  -- | 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 (gets (S.member w . mapped)) $ withDisplay $ \d -> do
      cMask <- asks $ clientMask . config
      io $ do selectInput d w (cMask .&. complement structureNotifyMask)
              unmapWindow d w
              selectInput d w cMask
      setWMState w iconicState
      -- this part is key: we increment the waitingUnmap counter to distinguish
      -- between client and xmonad initiated unmaps.
      modify (\s -> s { waitingUnmap = M.insertWith (+) w 1 (waitingUnmap s)
                      , mapped       = S.delete w (mapped s) })
  
  -- | 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) $ modify (\s -> s { mapped = S.insert w (mapped s) })
  
  -- | Set some properties when we initially gain control of a window
  setInitialProperties :: Window -> X ()
  setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do
      setWMState w iconicState
      asks (clientMask . config) >>= io . selectInput d w
      bw <- asks (borderWidth . config)
      io $ setWindowBorderWidth d w bw
      -- we must initially set the color of new windows, to maintain invariants
      -- required by the border setting in 'windows'
      io $ setWindowBorder d w nb
  
  -- | 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
      bw <- (fromIntegral . wa_border_width) <$> io (getWindowAttributes d w)
      -- give all windows at least 1x1 pixels
      let least x | x <= bw*2  = 1
                  | otherwise  = x - bw*2
      io $ moveResizeWindow d w (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@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) ->
          let (xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs
              (a:as)   = zipWith3 W.Screen xs [0..] $ map SD xinesc
          in  ws { W.current = a
                 , W.visible = as
                 , W.hidden  = ys }
  
  -- ---------------------------------------------------------------------
  
  -- | 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.workspace
          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.current ws : W.visible ws) $ \wk ->
          forM_ (W.index (W.view (W.tag (W.workspace 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.workspace . 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.workspace = (W.workspace $ W.current ws)
                                    { W.layout = l' }}}
  
  -- | Send a message to all layouts, without refreshing.
  broadcastMessage :: Message a => a -> X ()
  broadcastMessage a = withWindowSet $ \ws -> do
     let c = W.workspace . W.current $ ws
         v = map W.workspace . W.visible $ ws
         h = W.hidden ws
     mapM_ (sendMessageWithNoRefresh a) (c : v ++ h)
  
  -- | 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.workspace = ws })}) <- gets windowset
      handleMessage (W.layout ws) (SomeMessage ReleaseResources)
      windows $ const $ ss {W.current = c { W.workspace = 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` map (W.tag . W.workspace) (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
  