summaryrefslogtreecommitdiffstats
path: root/XMonad/Operations.hs
diff options
context:
space:
mode:
Diffstat (limited to 'XMonad/Operations.hs')
-rw-r--r--XMonad/Operations.hs588
1 files changed, 0 insertions, 588 deletions
diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs
deleted file mode 100644
index 294d4a8..0000000
--- a/XMonad/Operations.hs
+++ /dev/null
@@ -1,588 +0,0 @@
-{-# 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 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