module XMonad.Layout (
ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..),
Full(..), Tall(..), Mirror(..), 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)
data Resize = Shrink | Expand deriving Typeable
data IncMasterN = IncMasterN !Int deriving Typeable
instance Message Resize
instance Message IncMasterN
data Full a = Full deriving (Show, Read)
instance LayoutClass Full a
data Tall a = Tall !Int !Rational !Rational deriving (Show, Read)
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 $ fracdelta)
resize Expand = Tall nmaster delta (min 1 $ frac+delta)
incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac
description _ = "Tall"
tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle]
tile f r nmaster n = if n <= nmaster || nmaster == 0
then splitVertically n r
else splitVertically nmaster r1 ++ splitVertically (nnmaster) r2
where (r1,r2) = splitHorizontallyBy f r
splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle]
splitVertically n r | n < 2 = [r]
splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh :
splitVertically (n1) (Rectangle sx (sy+fromIntegral smallh) sw (shsmallh))
where smallh = sh `div` fromIntegral n
splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect
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 (swfromIntegral leftw) sh)
where leftw = floor $ fromIntegral sw * f
splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect
data 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
mirrorRect :: Rectangle -> Rectangle
mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw)
data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable)
instance Message ChangeLayout
(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a
(|||) = flip SLeft
infixr 5 |||
data Choose l r a = SLeft (r a) (l a)
| SRight (l a) (r a) deriving (Read, Show)
data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable)
instance Message NextNoWrap
instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where
runLayout (W.Workspace i (SLeft r l) ms) =
fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms)
runLayout (W.Workspace i (SRight l r) ms) =
fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms)
description (SLeft _ l) = description l
description (SRight _ r) = description r
handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of
SLeft {} -> return Nothing
SRight l r -> fmap (Just . flip SLeft l . fromMaybe r)
$ handleMessage r (SomeMessage Hide)
handleMessage lr m | Just NextLayout <- fromMessage m = do
mlr <- handleMessage lr $ SomeMessage NextNoWrap
maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr
handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do
handleMessage l (SomeMessage Hide)
mr <- handleMessage r (SomeMessage FirstLayout)
return . Just . SRight l $ fromMaybe r mr
handleMessage lr m | Just ReleaseResources <- fromMessage m =
liftM2 ((Just .) . cons)
(fmap (fromMaybe l) $ handleMessage l m)
(fmap (fromMaybe r) $ handleMessage r m)
where (cons, l, r) = case lr of
(SLeft r' l') -> (flip SLeft, l', r')
(SRight l' r') -> (SRight, l', r')
handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m
handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m