mirror of
https://github.com/xmonad/xmonad.git
synced 2025-05-19 08:30:21 -07:00
211 lines
8.3 KiB
Haskell
211 lines
8.3 KiB
Haskell
{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
|
|
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
|
|
|
|
-- --------------------------------------------------------------------------
|
|
-- |
|
|
-- Module : XMonad.Layout
|
|
-- Copyright : (c) Spencer Janssen 2007
|
|
-- License : BSD3-style (see LICENSE)
|
|
--
|
|
-- Maintainer : spencerjanssen@gmail.com
|
|
-- Stability : unstable
|
|
-- Portability : not portable, Typeable deriving, mtl, posix
|
|
--
|
|
-- The collection of core layouts.
|
|
--
|
|
-----------------------------------------------------------------------------
|
|
|
|
module XMonad.Layout (
|
|
Full(..), Tall(..), Mirror(..),
|
|
Resize(..), IncMasterN(..), Choose, (|||), ChangeLayout(..),
|
|
mirrorRect, splitVertically,
|
|
splitHorizontally, splitHorizontallyBy, splitVerticallyBy,
|
|
|
|
tile
|
|
|
|
) where
|
|
|
|
import XMonad.Core
|
|
|
|
import Graphics.X11 (Rectangle(..))
|
|
import qualified XMonad.StackSet as W
|
|
import Control.Arrow ((***), second)
|
|
import Control.Monad
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
-- | Change the size of the master pane.
|
|
data Resize = Shrink | Expand deriving Typeable
|
|
|
|
-- | Increase the number of clients in the master pane.
|
|
data IncMasterN = IncMasterN !Int deriving Typeable
|
|
|
|
instance Message Resize
|
|
instance Message IncMasterN
|
|
|
|
-- | Simple fullscreen mode. Renders the focused window fullscreen.
|
|
data Full a = Full deriving (Show, Read)
|
|
|
|
instance LayoutClass Full a
|
|
|
|
-- | The builtin tiling mode of xmonad. Supports 'Shrink', 'Expand' and
|
|
-- 'IncMasterN'.
|
|
data Tall a = Tall { tallNMaster :: !Int -- ^ The default number of windows in the master pane (default: 1)
|
|
, tallRatioIncrement :: !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100)
|
|
, tallRatio :: !Rational } -- ^ Default proportion of screen occupied by master pane (default: 1/2)
|
|
deriving (Show, Read)
|
|
-- TODO should be capped [0..1] ..
|
|
|
|
-- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs
|
|
instance LayoutClass Tall a where
|
|
pureLayout (Tall nmaster _ frac) r s = zip ws rs
|
|
where ws = W.integrate s
|
|
rs = tile frac r nmaster (length ws)
|
|
|
|
pureMessage (Tall nmaster delta frac) m =
|
|
msum [fmap resize (fromMessage m)
|
|
,fmap incmastern (fromMessage m)]
|
|
|
|
where resize Shrink = Tall nmaster delta (max 0 $ frac-delta)
|
|
resize Expand = Tall nmaster delta (min 1 $ frac+delta)
|
|
incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac
|
|
|
|
description _ = "Tall"
|
|
|
|
-- | Compute the positions for windows using the default two-pane tiling
|
|
-- algorithm.
|
|
--
|
|
-- The screen is divided into two panes. All clients are
|
|
-- then partioned between these two panes. One pane, the master, by
|
|
-- convention has the least number of windows in it.
|
|
tile
|
|
:: Rational -- ^ @frac@, what proportion of the screen to devote to the master area
|
|
-> Rectangle -- ^ @r@, the rectangle representing the screen
|
|
-> Int -- ^ @nmaster@, the number of windows in the master pane
|
|
-> Int -- ^ @n@, the total number of windows to tile
|
|
-> [Rectangle]
|
|
tile f r nmaster n = if n <= nmaster || nmaster == 0
|
|
then splitVertically n r
|
|
else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns
|
|
where (r1,r2) = splitHorizontallyBy f r
|
|
|
|
--
|
|
-- Divide the screen vertically into n subrectangles
|
|
--
|
|
splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle]
|
|
splitVertically n r | n < 2 = [r]
|
|
splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh :
|
|
splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh))
|
|
where smallh = sh `div` fromIntegral n --hmm, this is a fold or map.
|
|
|
|
-- Not used in the core, but exported
|
|
splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect
|
|
|
|
-- Divide the screen into two rectangles, using a rational to specify the ratio
|
|
splitHorizontallyBy, splitVerticallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle)
|
|
splitHorizontallyBy f (Rectangle sx sy sw sh) =
|
|
( Rectangle sx sy leftw sh
|
|
, Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh)
|
|
where leftw = floor $ fromIntegral sw * f
|
|
|
|
-- Not used in the core, but exported
|
|
splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
-- | Mirror a layout, compute its 90 degree rotated form.
|
|
newtype Mirror l a = Mirror (l a) deriving (Show, Read)
|
|
|
|
instance LayoutClass l a => LayoutClass (Mirror l) a where
|
|
runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror)
|
|
`fmap` runLayout (W.Workspace i l ms) (mirrorRect r)
|
|
handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l
|
|
description (Mirror l) = "Mirror "++ description l
|
|
|
|
-- | Mirror a rectangle.
|
|
mirrorRect :: Rectangle -> Rectangle
|
|
mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw)
|
|
|
|
------------------------------------------------------------------------
|
|
-- LayoutClass selection manager
|
|
-- Layouts that transition between other layouts
|
|
|
|
-- | Messages to change the current layout.
|
|
data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable)
|
|
|
|
instance Message ChangeLayout
|
|
|
|
-- | The layout choice combinator
|
|
(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a
|
|
(|||) = Choose L
|
|
infixr 5 |||
|
|
|
|
-- | A layout that allows users to switch between various layout options.
|
|
data Choose l r a = Choose LR (l a) (r a) deriving (Read, Show)
|
|
|
|
-- | Are we on the left or right sub-layout?
|
|
data LR = L | R deriving (Read, Show, Eq)
|
|
|
|
data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable)
|
|
instance Message NextNoWrap
|
|
|
|
-- | A small wrapper around handleMessage, as it is tedious to write
|
|
-- SomeMessage repeatedly.
|
|
handle :: (LayoutClass l a, Message m) => l a -> m -> X (Maybe (l a))
|
|
handle l m = handleMessage l (SomeMessage m)
|
|
|
|
-- | A smart constructor that takes some potential modifications, returns a
|
|
-- new structure if any fields have changed, and performs any necessary cleanup
|
|
-- on newly non-visible layouts.
|
|
choose :: (LayoutClass l a, LayoutClass r a)
|
|
=> Choose l r a-> LR -> Maybe (l a) -> Maybe (r a) -> X (Maybe (Choose l r a))
|
|
choose (Choose d _ _) d' Nothing Nothing | d == d' = return Nothing
|
|
choose (Choose d l r) d' ml mr = f lr
|
|
where
|
|
(l', r') = (fromMaybe l ml, fromMaybe r mr)
|
|
lr = case (d, d') of
|
|
(L, R) -> (hide l' , return r')
|
|
(R, L) -> (return l', hide r' )
|
|
(_, _) -> (return l', return r')
|
|
f (x,y) = fmap Just $ liftM2 (Choose d') x y
|
|
hide x = fmap (fromMaybe x) $ handle x Hide
|
|
|
|
instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where
|
|
runLayout (W.Workspace i (Choose L l r) ms) =
|
|
fmap (second . fmap $ flip (Choose L) $ r) . runLayout (W.Workspace i l ms)
|
|
runLayout (W.Workspace i (Choose R l r) ms) =
|
|
fmap (second . fmap $ Choose R l) . runLayout (W.Workspace i r ms)
|
|
|
|
description (Choose L l _) = description l
|
|
description (Choose R _ r) = description r
|
|
|
|
handleMessage lr m | Just NextLayout <- fromMessage m = do
|
|
mlr' <- handle lr NextNoWrap
|
|
maybe (handle lr FirstLayout) (return . Just) mlr'
|
|
|
|
handleMessage c@(Choose d l r) m | Just NextNoWrap <- fromMessage m =
|
|
case d of
|
|
L -> do
|
|
ml <- handle l NextNoWrap
|
|
case ml of
|
|
Just _ -> choose c L ml Nothing
|
|
Nothing -> choose c R Nothing =<< handle r FirstLayout
|
|
|
|
R -> choose c R Nothing =<< handle r NextNoWrap
|
|
|
|
handleMessage c@(Choose _ l _) m | Just FirstLayout <- fromMessage m = do
|
|
flip (choose c L) Nothing =<< handle l FirstLayout
|
|
|
|
handleMessage c@(Choose d l r) m | Just ReleaseResources <- fromMessage m =
|
|
join $ liftM2 (choose c d) (handle l ReleaseResources) (handle r ReleaseResources)
|
|
|
|
handleMessage c@(Choose d l r) m = do
|
|
ml' <- case d of
|
|
L -> handleMessage l m
|
|
R -> return Nothing
|
|
mr' <- case d of
|
|
L -> return Nothing
|
|
R -> handleMessage r m
|
|
choose c d ml' mr'
|